;;; reddigg-rss.el --- RSS backend for reddigg -*- lexical-binding: t; -*- ;; Reddit rejects unauthenticated .json requests with HTTP 403, while ;; the Atom feeds (.rss) remain open. This library reroutes reddigg's ;; requests to the feeds and converts entries into the JSON-shaped ;; hash tables reddigg renders. ;; ;; Limitations of the feeds: no scores, no comment counts, comments ;; come flat (no tree, capped by feed size), and "load more comments" ;; is unavailable. ;; ;; Setup: (require 'reddigg-rss) after reddigg. ;;; Code: (require 'dom) (require 'shr) (require 'plz) (require 'promise) (require 'rx) (require 'seq) (defvar reddigg-rss-user-agent "Mozilla/5.0 (Macintosh; Intel Mac OS X 10.15; rv:120.0) Gecko/20100101 Firefox/120.0" "User-Agent sent to reddit.com; the default Emacs agent is blocked.") (defun reddigg-rss--ht (&rest kvs) "Build an equal hash table from KVS pairs." (let ((h (make-hash-table :test 'equal))) (while kvs (puthash (pop kvs) (pop kvs) h)) h)) (defun reddigg-rss--rewrite-url (url) "Rewrite reddigg's JSON api URL to the matching Atom feed." (let* ((u (replace-regexp-in-string (rx bos "https://" (? (or "old." "www.")) "reddit.com") "https://www.reddit.com" url)) (u (replace-regexp-in-string (rx "//" (group "r/")) "/\\1" u))) (replace-regexp-in-string (rx "//.rss") "/.rss" (replace-regexp-in-string (rx ".json" (? "?" (group (* any))) eos) (lambda (m) (let ((query (match-string 1 m))) (concat "/.rss" (when (and query (not (string-empty-p query))) (concat "?" query))))) u t)))) (defun reddigg-rss--add-limit (url) "Ask for a bigger page in URL; the feeds default to 25 entries." (if (string-match-p "limit=" url) url (concat url (if (string-match-p "?" url) "&" "?") "limit=100"))) (defvar reddigg-rss-max-retries 2 "How many times to retry a rate-limited request.") (defvar reddigg-rss--cooldown-until nil "Time before which reddit requests are pointless, or nil.") (defun reddigg-rss--cooldown-left () "Seconds of rate-limit cooldown left, or nil when clear." (when reddigg-rss--cooldown-until (let ((left (- reddigg-rss--cooldown-until (float-time)))) (if (> left 0) (ceiling left) (setq reddigg-rss--cooldown-until nil))))) (defun reddigg-rss--retry-after (err) "Seconds until the rate limit resets, per ERR's response headers." (let* ((resp (plz-error-response err)) (headers (and resp (plz-response-headers resp))) (reset (cdr (assq 'x-ratelimit-reset headers)))) (1+ (if reset (string-to-number (format "%s" reset)) 30)))) (defun reddigg-rss--fetch (url resolve reject attempt) "Fetch feed URL, retrying on HTTP 429; call RESOLVE or REJECT. ATTEMPT counts retries so far." (let ((left (reddigg-rss--cooldown-left))) (if left (funcall reject (format "reddit rate limited, resets in %ds" left)) (plz 'get url :headers `(("User-Agent" . ,reddigg-rss-user-agent)) :as 'string :connect-timeout 5 :timeout 30 :then (lambda (body) (condition-case ex (funcall resolve (with-temp-buffer (insert body) (libxml-parse-xml-region (point-min) (point-max)))) (error (funcall reject ex)))) :else (lambda (err) (let ((status (and (plz-error-response err) (plz-response-status (plz-error-response err))))) (if (eql status 429) (let ((wait (reddigg-rss--retry-after err))) (if (and (< attempt reddigg-rss-max-retries) (<= wait 90)) (progn (message "reddigg-rss: rate limited, retrying in %ss..." wait) (run-at-time wait nil #'reddigg-rss--fetch url resolve reject (1+ attempt))) (setq reddigg-rss--cooldown-until (+ (float-time) wait)) (funcall reject (format "reddit rate limited, resets in %ds" wait)))) (funcall reject err)))))))) (defun reddigg-rss--promise-feed (url) "Promise a parsed Atom dom from URL." (promise-new (lambda (resolve reject) (reddigg-rss--fetch url resolve reject 0)))) (defun reddigg-rss--html-to-text (html) "Render HTML string to plain text." (if (or (null html) (string-empty-p html)) "" (with-temp-buffer (insert html) (let ((dom (libxml-parse-html-region (point-min) (point-max))) (shr-width 10000) (shr-use-fonts nil) (shr-inhibit-images t)) (erase-buffer) (shr-insert-document dom) (string-trim (buffer-string)))))) (defun reddigg-rss--entry-content-dom (entry) "Parse ENTRY's html content into a dom, or nil." (let ((html (dom-text (car (dom-by-tag entry 'content))))) (unless (string-empty-p html) (with-temp-buffer (insert html) (libxml-parse-html-region (point-min) (point-max)))))) (defun reddigg-rss--post-external-url (entry permalink) "External URL of ENTRY: href of its [link] anchor, or PERMALINK." (or (catch 'found (let ((cdom (reddigg-rss--entry-content-dom entry))) (dolist (a (and cdom (dom-by-tag cdom 'a))) (when (string= (string-trim (dom-texts a)) "[link]") (throw 'found (dom-attr a 'href)))))) permalink)) (defun reddigg-rss--post-selftext (entry) "Self text of ENTRY: the div.md part of its content, as plain text." (let* ((cdom (reddigg-rss--entry-content-dom entry)) (md (catch 'found (dolist (d (and cdom (dom-by-tag cdom 'div))) (when (string-match-p "\\bmd\\b" (or (dom-attr d 'class) "")) (throw 'found d)))))) (if (null md) "" (with-temp-buffer (let ((shr-width 10000) (shr-use-fonts nil) (shr-inhibit-images t)) (shr-insert-document md)) (string-trim (buffer-string)))))) (defun reddigg-rss--entry-field (entry tag) "Text of TAG inside ENTRY." (dom-text (car (dom-by-tag entry tag)))) (defun reddigg-rss--entry-author (entry) "Author name of ENTRY without the /u/ prefix." (string-remove-prefix "/u/" (string-trim (dom-text (car (dom-by-tag entry 'name)))))) (defun reddigg-rss--entry-link (entry) "Href of ENTRY's plain link element." (dom-attr (car (dom-by-tag entry 'link)) 'href)) (defun reddigg-rss--permalink (entry) "ENTRY's link as a site-relative permalink." (replace-regexp-in-string (rx bos "https://" (? (or "old." "www.")) "reddit.com") "" (or (reddigg-rss--entry-link entry) ""))) (defun reddigg-rss--entry-subreddit (entry) "Prefixed subreddit label of ENTRY." (or (dom-attr (car (dom-by-tag entry 'category)) 'label) "r/?")) (defun reddigg-rss--post-data (entry) "Convert a post ENTRY to reddigg's post data hash." (let ((permalink (reddigg-rss--permalink entry))) (reddigg-rss--ht "title" (reddigg-rss--entry-field entry 'title) "name" (reddigg-rss--entry-field entry 'id) "author" (reddigg-rss--entry-author entry) "subreddit_name_prefixed" (reddigg-rss--entry-subreddit entry) "score" "-" "num_comments" "-" "created_utc" (date-to-time (reddigg-rss--entry-field entry 'updated)) "permalink" permalink "url" (reddigg-rss--post-external-url entry permalink) "selftext" (reddigg-rss--post-selftext entry)))) (defun reddigg-rss--comment-data (entry) "Convert a comment ENTRY to reddigg's comment item hash." (reddigg-rss--ht "kind" "t1" "data" (reddigg-rss--ht "author" (reddigg-rss--entry-author entry) "body" (reddigg-rss--post-selftext entry) "depth" 0 "replies" ""))) (defun reddigg-rss--listing (children &optional after) "Wrap CHILDREN vector into a listing hash with AFTER cursor." (reddigg-rss--ht "data" (reddigg-rss--ht "children" children "after" after))) (defun reddigg-rss--convert-sub (dom) "Convert a subreddit feed DOM to a listing hash." (let* ((entries (dom-by-tag dom 'entry)) (children (vconcat (mapcar (lambda (e) (reddigg-rss--ht "data" (reddigg-rss--post-data e))) entries))) (after (and entries (reddigg-rss--entry-field (car (last entries)) 'id)))) (reddigg-rss--listing children after))) (defun reddigg-rss--convert-comments (dom) "Convert a post feed DOM to reddigg's two-listing vector." (let* ((entries (dom-by-tag dom 'entry)) (post (or (seq-find (lambda (e) (string-prefix-p "t3_" (reddigg-rss--entry-field e 'id))) entries) (car entries))) (comments (seq-filter (lambda (e) (string-prefix-p "t1_" (reddigg-rss--entry-field e 'id))) entries))) (vector (reddigg-rss--listing (vector (reddigg-rss--ht "data" (reddigg-rss--post-data post)))) (reddigg-rss--listing (vconcat (mapcar #'reddigg-rss--comment-data comments)))))) (defun reddigg-rss--promise-json (_orig url) "Serve reddigg's request for URL from the Atom feed instead." (let ((feed-url (reddigg-rss--add-limit (reddigg-rss--rewrite-url url))) (comments-p (string-match-p "/comments/" url))) (promise-chain (reddigg-rss--promise-feed feed-url) (then (lambda (dom) (if comments-p (reddigg-rss--convert-comments dom) (reddigg-rss--convert-sub dom))))))) (advice-add 'reddigg--promise-json :around #'reddigg-rss--promise-json) ;;; Galleries ;; Gallery posts carry no image URLs in the feeds, only a ;; reddit.com/gallery/ link. The old.reddit HTML page still lists ;; every image, so expand galleries from there. (defconst reddigg-rss--gallery-link-rx (rx "https://" (? "www.") "reddit.com/gallery/" (group (+ (any alnum)))) "Regexp matching a reddit gallery link, group 1 is the post id.") (defvar reddigg-rss--gallery-cache (make-hash-table :test 'equal) "Post id -> list of image URLs, resolved this session.") (defconst reddigg-rss--preview-img-rx ;; external-preview.redd.it names do not exist on i.redd.it, hence ;; the leading boundary (rx (or bos (not (any "-." alnum))) "preview.redd.it/" (group (+ (any alnum)) "." (or "jpeg" "jpg" "png" "webp" "gif"))) "Regexp matching a preview.redd.it image, group 1 is the file name.") (defun reddigg-rss--preview-images (html) "Full-resolution i.redd.it URLs of all preview images in HTML string." (let ((urls nil) (start 0)) (while (string-match reddigg-rss--preview-img-rx html start) (setq start (match-end 0)) (push (concat "https://i.redd.it/" (match-string 1 html)) urls)) (nreverse (delete-dups urls)))) (defun reddigg-rss--parse-gallery (html post-id) "Extract and cache image URLs of POST-ID from its page HTML." (puthash post-id (reddigg-rss--preview-images html) reddigg-rss--gallery-cache)) (defun reddigg-rss--parse-listing-galleries (html) "Cache the images of every post on an old.reddit listing page HTML. Return the number of posts cached." (let ((chunks (split-string html "data-fullname=\"t3_")) (count 0)) (dolist (chunk (cdr chunks)) (when (string-match (rx bos (group (+ (any alnum))) "\"") chunk) (let ((id (match-string 1 chunk)) (urls (reddigg-rss--preview-images chunk))) (when urls (puthash id urls reddigg-rss--gallery-cache) (setq count (1+ count)))))) count)) (defun reddigg-rss--buffer-listing-url () "Old.reddit listing URL matching this reddigg sub buffer, or nil." (save-excursion (goto-char (point-min)) (when (re-search-forward (rx bol "#+title: " (group (+ (not (any " \n")))) " sorted by " (group (+ (not (any " \n")))) (? " " (group (+ (not (any " \n")))))) 1000 t) (let ((sub (match-string-no-properties 1)) (sort (match-string-no-properties 2)) (scope (match-string-no-properties 3))) (concat "https://old.reddit.com/r/" sub "/" (unless (string= sort "default") (concat sort "/")) "?limit=100" (when scope (concat "&t=" scope))))))) (defun reddigg-rss-prefetch-galleries (url callback) "Cache gallery images of every post on listing page URL, then CALLBACK. Asynchronous; rate-limit failures are treated as a cache miss." (if (reddigg-rss--cooldown-left) (funcall callback 0) (plz 'get url :headers `(("User-Agent" . ,reddigg-rss-user-agent) ("Cookie" . "over18=1")) :as 'string :connect-timeout 5 :timeout 30 :then (lambda (html) (let ((n (reddigg-rss--parse-listing-galleries html))) (message "reddigg-rss: prefetched galleries of %d posts" n) (funcall callback n))) :else (lambda (err) (let ((status (and (plz-error-response err) (plz-response-status (plz-error-response err))))) (when (eql status 429) (setq reddigg-rss--cooldown-until (+ (float-time) (reddigg-rss--retry-after err))))) (funcall callback 0))))) (defun reddigg-rss--fetch-gallery (post-id callback) "Call CALLBACK with image URLs of gallery POST-ID, nil on failure. Asynchronous. Results are cached; a 429 enters a cooldown so subsequent calls fail fast." (let ((cached (gethash post-id reddigg-rss--gallery-cache))) (cond (cached (funcall callback cached)) ((reddigg-rss--cooldown-left) (funcall callback nil)) (t (plz 'get (format "https://old.reddit.com/comments/%s/" post-id) :headers `(("User-Agent" . ,reddigg-rss-user-agent) ("Cookie" . "over18=1")) :as 'string :connect-timeout 5 :timeout 30 :then (lambda (html) (funcall callback (reddigg-rss--parse-gallery html post-id))) :else (lambda (err) (let ((status (and (plz-error-response err) (plz-response-status (plz-error-response err))))) (when (eql status 429) (setq reddigg-rss--cooldown-until (+ (float-time) (reddigg-rss--retry-after err))))) (funcall callback nil))))))) (defun reddigg-rss-resolve-galleries (post-ids callback) "Resolve POST-IDS one at a time, then call CALLBACK. CALLBACK receives a hash table of post id -> image URLs (nil for galleries that failed)." (let ((table (make-hash-table :test 'equal)) (ids (copy-sequence post-ids)) worker) (setq worker (lambda () (if (null ids) (funcall callback table) (let ((id (pop ids))) (reddigg-rss--fetch-gallery id (lambda (urls) (puthash id urls table) (funcall worker))))))) (funcall worker))) (defun reddigg-rss-resolve-buffer-galleries (post-ids callback) "Resolve POST-IDS of galleries linked in the current buffer. Like `reddigg-rss-resolve-galleries', but when the buffer is a reddigg sub listing with several unresolved galleries, warm the cache with a single fetch of the matching old.reddit listing page first." (let ((uncached (cl-remove-if (lambda (id) (gethash id reddigg-rss--gallery-cache)) post-ids)) (listing (reddigg-rss--buffer-listing-url))) (if (and listing (> (length uncached) 1)) (reddigg-rss-prefetch-galleries listing (lambda (_n) (reddigg-rss-resolve-galleries post-ids callback))) (reddigg-rss-resolve-galleries post-ids callback)))) (defun reddigg-rss-expand-galleries (&optional callback) "Expand reddit gallery links in current buffer into image URLs. Asynchronous: image URLs are inserted under each link as they arrive. Stops fetching when reddit rate-limits, expanding what it got. CALLBACK, when given, is called with the number of images inserted once done." (interactive) (let ((buf (current-buffer)) (links nil)) (save-excursion (goto-char (point-min)) (while (re-search-forward reddigg-rss--gallery-link-rx nil t) (push (cons (match-string-no-properties 1) (copy-marker (line-end-position))) links))) (setq links (nreverse links)) (reddigg-rss-resolve-buffer-galleries (delete-dups (mapcar #'car links)) (lambda (table) (let ((expanded 0) (skipped 0)) (when (buffer-live-p buf) (with-current-buffer buf (let ((inhibit-read-only t)) (save-excursion (pcase-dolist (`(,id . ,marker) links) (let ((urls (gethash id table))) (if (null urls) (setq skipped (1+ skipped)) (setq expanded (+ expanded (length urls))) (goto-char marker) (insert "\n" (mapconcat #'identity urls "\n"))))))))) (if (zerop skipped) (message "reddigg-rss: expanded %d gallery images" expanded) (message "reddigg-rss: expanded %d images, skipped %d galleries%s" expanded skipped (let ((left (reddigg-rss--cooldown-left))) (if left (format " (rate limited, resets in %ds)" left) "")))) (when callback (funcall callback expanded))))))) (provide 'reddigg-rss) ;;; reddigg-rss.el ends here