commit c96e27f23406354be080776ce77a2ba8bf0c706d
parent 218d60b2690051456f90f26bac865858322465cc
Author: Yuval Langer <yuval.langer@gmail.com>
Date: Wed, 26 Jun 2024 14:10:38 +0300
Add functions and customization variables for more than one OPML.
Diffstat:
1 file changed, 84 insertions(+), 32 deletions(-)
diff --git a/get-craftering-opml.el b/get-craftering-opml.el
@@ -28,19 +28,33 @@
;;; Code:
-(defcustom gco--craftering-url
- "https://craftering.systemcrafters.net/Craftering.opml"
- "Craftering OPML address."
+(defcustom gco-opml-list
+ '(("https://craftering.systemcrafters.net/Craftering.opml" blog craftering)
+ ("https://planet.debian.org/opml.xml" blog debian planet))
+ "A list holding the OPML URLs.
+
+Each member is either a string or the URL, or a list with the URL
+as the first member and optional tags.
+
+The tags would be attached to each feed in the OPML file."
+ :type
+ '(repeat (choice string
+ (cons string (repeat symbol)))))
+
+(defcustom gco-elfeed-feeds
+ '()
+ "The GCO `elfeed-feeds'."
:type
- '(string))
+ '(repeat (choice string
+ (cons string (repeat symbol)))))
(defun gco--blogger-name-to-symbol (blogger-name)
(intern (downcase (replace-regexp-in-string "[ .]+"
"-"
blogger-name))))
-(defun gco--get-response-buffer ()
- (url-retrieve-synchronously gco--craftering-url))
+(defun gco--get-response-buffer (opml-url)
+ (url-retrieve-synchronously opml-url))
(defun gco--url-response-body-position (response-buffer)
(with-current-buffer response-buffer
@@ -56,7 +70,7 @@
(t
(loop (1+ position)))))))
-(defun gco--parse-response-buffer-opml (response-buffer)
+(defun gco--parse-response-buffer-to-xml (response-buffer)
(with-current-buffer response-buffer
(let ((beg (gco--url-response-body-position response-buffer))
(end (buffer-end 1)))
@@ -64,30 +78,48 @@
end
response-buffer))))
-(defun gco--response-buffer-to-elfeed-feed (response-buffer)
- (let ((xml (gco--parse-response-buffer-opml response-buffer)))
- (pcase xml
- (`((opml . ,rest-of-opml))
- (let ((body (assq 'body rest-of-opml)))
- (pcase body
- ;; TODO: What the hell is this?
- (`(body ,TODO-WHAT-THE-HELL-IS-THIS? . ,outlines)
- (named-let loop ((outlines outlines)
- (accumulator '()))
- (pcase outlines
- ('()
- accumulator)
- (`((outline . (,outline-values)) . ,rest-of-outlines)
- (let ((text (cdr (assq 'text
- outline-values)))
- (xml-url (cdr (assq 'xmlUrl
- outline-values))))
- (loop rest-of-outlines
- (cons (list xml-url
- 'blog
- 'craftering
- (gco--blogger-name-to-symbol text))
- accumulator)))))))))))))
+(defun gco--xml-to-opml-outlines (xml)
+ (pcase xml
+ (`((opml . ,rest-of-opml))
+ (let ((body (assq 'body rest-of-opml)))
+ (pcase body
+ ;; TODO: What the hell is this?
+ (`(body ,TODO-WHAT-THE-HELL-IS-THIS? . ,outlines)
+ outlines))))))
+
+(cl-defun gco--response-buffer-to-elfeed-feed (response-buffer &key (tags '()))
+ (let* ((xml (gco--parse-response-buffer-to-xml response-buffer))
+ (outlines (gco--xml-to-opml-outlines xml)))
+ (named-let loop ((outlines outlines)
+ (accumulator '()))
+ (cond
+ ((null outlines)
+ accumulator)
+ ((and (consp (car outlines))
+ (eq (caar outlines)
+ 'outline))
+ (let* ((outline-values (cadar outlines))
+ (rest-of-outlines (cdr outlines))
+ (text (cdr (assq 'text
+ outline-values)))
+ (xml-url (cdr (assq 'xmlUrl
+ outline-values)))
+ (blogger-name-tag (gco--blogger-name-to-symbol text))
+ (elfeed-feed-entry (append (list xml-url)
+ (elfeed-normalize-tags
+ (list blogger-name-tag)
+ tags))))
+ (cond
+ ((string-empty-p xml-url)
+ (loop rest-of-outlines
+ accumulator))
+ (t
+ (loop rest-of-outlines
+ (cons elfeed-feed-entry
+ accumulator))))))
+ ((stringp (car outlines))
+ (loop (cdr outlines)
+ accumulator))))))
(defun gco--elfeed-feeds-entry-url (elfeed-feeds-entry)
"Takes an `elfeed-feeds' kind of entry as ELFEED-FEEDS-ENTRY and return its URL."
@@ -117,7 +149,7 @@ patch if you know."
(sort (hash-table-keys hash-table)
'string<)))
-(defun gco--deduplicate-elfeed-feeds (elfeed-feeds)
+(defun gco--normalise-elfeed-feeds (elfeed-feeds)
(let (;; XXX: Pass ":test 'equal" into make-hash-table so that
;; string comparisons work, otherwise it'll put many of the
;; same string as keys, each with its own values, like:
@@ -142,6 +174,26 @@ patch if you know."
(loop rest-of-entries)))))
(gco--hash-table-to-alist hash)))
+(defun gco--update-gco-efleed-feeds ()
+ (named-let loop ((opml-list (reverse gco-opml-list))
+ (our-elfeed-feeds '()))
+ (pcase opml-list
+ ('()
+ our-elfeed-feeds)
+ (`(,opml-list-entry . ,rest-of-opml-list)
+ (let* ((url+tags (cond
+ ((stringp opml-list-entry)
+ (list opml-list-entry))
+ ((and (consp opml-list-entry)
+ (stringp (car opml-list-entry)))
+ opml-list-entry)))
+ (url (car url+tags))
+ (tags (cdr url+tags))
+ (response-buffer (gco--get-response-buffer url)))
+ (loop rest-of-opml-list
+ (append (gco--response-buffer-to-elfeed-feed response-buffer :tags tags)
+ our-elfeed-feeds)))))))
+
(provide 'get-craftering-opml)
;; Local Variables:
