get-craftering-opml.el (8328B)
1 ;;; get-craftering-opml.el --- Gets you the elfeed-list of the Craftering. -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2024 Yuval Langer 4 5 ;; Author: Yuval Langer <yuval.langer@gmail.com> 6 ;; Version: 0.0.0 7 ;; Keywords: TODO 8 ;; URL: https://codeberg.org/kakafarm/emacs-get-craftering-opml/ 9 10 ;; This program is free software; you can redistribute it and/or modify 11 ;; it under the terms of the GNU General Public License as published by 12 ;; the Free Software Foundation, either version 3 of the License, or 13 ;; (at your option) any later version. 14 15 ;; This program is distributed in the hope that it will be useful, 16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18 ;; GNU General Public License for more details. 19 20 ;; You should have received a copy of the GNU General Public License 21 ;; along with this program. If not, see <https://www.gnu.org/licenses/>. 22 23 ;;; Commentary: 24 25 ;; Usage: 26 ;; 27 ;; TODO: Remains to be decided! 28 29 ;;; Code: 30 31 (defcustom gco-opml-list 32 '(("https://craftering.systemcrafters.net/Craftering.opml" blog craftering) 33 ("https://planet.debian.org/opml.xml" blog debian planet)) 34 "A list holding the OPML URLs. 35 36 Each member is either a string or the URL, or a list with the URL 37 as the first member and optional tags. 38 39 The tags would be attached to each feed in the OPML file." 40 :type 41 '(repeat (choice string 42 (cons string (repeat symbol))))) 43 44 (defcustom gco-elfeed-feeds 45 '() 46 "The GCO `elfeed-feeds'." 47 :type 48 '(repeat (choice string 49 (cons string (repeat symbol))))) 50 51 (defun gco--blogger-name-to-symbol (blogger-name) 52 (intern (downcase (replace-regexp-in-string "[ .()]+" 53 "-" 54 blogger-name)))) 55 56 (defun gco--response-body-position (response-buffer) 57 (with-current-buffer response-buffer 58 (named-let loop ((position 1)) 59 (cond 60 ((>= (1+ position) 61 (buffer-end 1)) 62 nil) 63 ((string= (buffer-substring-no-properties position 64 (+ position 2)) 65 "\n\n") 66 (+ position 2)) 67 (t 68 (loop (1+ position))))))) 69 70 (defun gco--parse-response-buffer-to-xml (response-buffer) 71 (with-current-buffer response-buffer 72 (let ((start (gco--response-body-position response-buffer)) 73 (end (buffer-end 1))) 74 ;; (xml-parse-region beg 75 ;; end 76 ;; response-buffer) 77 (libxml-parse-xml-region start 78 end)))) 79 80 (defun gco--xml-to-opml-outlines (xml) 81 (pcase xml 82 (`(opml . ,rest-of-opml) 83 (let ((body (assq 'body 84 rest-of-opml))) 85 (pcase body 86 ;; TODO: What the hell is this? 87 (`(body ,TODO-WHAT-THE-HELL-IS-THIS? . ,outlines) 88 outlines)))))) 89 90 (cl-defun gco--response-buffer-to-elfeed-feed (response-buffer 91 &key 92 (tags '()) 93 (tag-blogger-name? '())) 94 (let* ((xml (gco--parse-response-buffer-to-xml response-buffer)) 95 (outlines (gco--xml-to-opml-outlines xml))) 96 (named-let loop ((outlines outlines) 97 (accumulator '())) 98 (cond 99 ((null outlines) 100 accumulator) 101 ((and (consp (car outlines)) 102 (eq (caar outlines) 103 'outline)) 104 (let* ((outline-values (cadar outlines)) 105 (rest-of-outlines (cdr outlines)) 106 (text (cdr (assq 'text 107 outline-values))) 108 (xml-url (cdr (assq 'xmlUrl 109 outline-values))) 110 (blogger-name-tag (gco--blogger-name-to-symbol text)) 111 (all-tags (elfeed-normalize-tags 112 (if tag-blogger-name? 113 (list blogger-name-tag) 114 '()) 115 tags)) 116 (elfeed-feed-entry (append (list xml-url) 117 all-tags))) 118 (cond 119 ((string-empty-p xml-url) 120 (loop rest-of-outlines 121 accumulator)) 122 (t 123 (loop rest-of-outlines 124 (cons elfeed-feed-entry 125 accumulator)))))) 126 ((stringp (car outlines)) 127 (loop (cdr outlines) 128 accumulator)))))) 129 130 (defun gco--elfeed-feeds-entry-url (elfeed-feeds-entry) 131 "Takes an `elfeed-feeds' kind of entry as ELFEED-FEEDS-ENTRY and return its URL." 132 (pcase elfeed-feeds-entry 133 (`(,url . ,tags) 134 url) 135 (url 136 url))) 137 138 (defun gco--elfeed-feeds-entry-tags (elfeed-feeds-entry) 139 "Takes an `elfeed-feeds' kind of entry as ELFEED-FEEDS-ENTRY and return its list of tags." 140 (pcase elfeed-feeds-entry 141 (`(,url . ,tags) 142 tags) 143 (url 144 '()))) 145 146 (defun gco--hash-table-to-alist (hash-table) 147 "Convert an hash-table HASH-TABLE to a list. 148 149 TODO: There MUST be a standard function for that, right? Send a 150 patch if you know." 151 (mapcar (lambda (key) 152 (cons key 153 (gethash key 154 hash-table))) 155 (sort (hash-table-keys hash-table) 156 'string<))) 157 158 (defun gco--normalise-elfeed-feeds (elfeed-feeds) 159 (let (;; XXX: Pass ":test 'equal" into make-hash-table so that 160 ;; string comparisons work, otherwise it'll put many of the 161 ;; same string as keys, each with its own values, like: 162 ;; 163 ;;'(("moo" a) ("moo" b)). 164 (hash (make-hash-table :test 'equal))) 165 (named-let loop ((entries elfeed-feeds)) 166 (pcase entries 167 ('() 168 '()) 169 (`(,entry . ,rest-of-entries) 170 (let* ((url (gco--elfeed-feeds-entry-url entry)) 171 (entry-tags (gco--elfeed-feeds-entry-tags entry)) 172 (hash-tags (gethash url 173 hash 174 '())) 175 (merged-tags (elfeed-normalize-tags (append hash-tags 176 entry-tags)))) 177 (puthash url 178 merged-tags 179 hash) 180 (loop rest-of-entries))))) 181 (gco--hash-table-to-alist hash))) 182 183 (defun gco--update-gco-efleed-feeds () 184 "TODO: This here supposed to take the opmls and add and dedup the GCO elfeed-feeds" 185 (let ((our-elfeed-feeds gco-elfeed-feeds)) 186 (dolist (opml-list-entry 187 gco-opml-list 188 (setq gco-elfeed-feeds (gco--normalise-elfeed-feeds 189 (apply 'append 190 our-elfeed-feeds)))) 191 (let* ((url+tags (cond 192 ;; If we have a simple string entry, 193 ((stringp opml-list-entry) 194 ;; convert to a tagged entry with empty tag 195 ;; list. 196 (list opml-list-entry)) 197 ;; If we have a tagged entry, 198 ((and (consp opml-list-entry) 199 (stringp (car opml-list-entry))) 200 ;; just evaluate to the entry. 201 (message "%S" opml-list-entry) 202 opml-list-entry))) 203 (url (car url+tags)) 204 (tags (cdr url+tags)) 205 (response-buffer (url-retrieve-synchronously url))) 206 (setq our-elfeed-feeds 207 (cons (gco--response-buffer-to-elfeed-feed response-buffer 208 :tags tags) 209 our-elfeed-feeds)))))) 210 211 ;;; XXX: Manual testing AHOY! 212 ;; gco-elfeed-feeds 213 ;; (gco--update-gco-efleed-feeds) 214 ;; (setq craftering (url-retrieve-synchronously (caar gco-opml-list))) 215 ;; (gco--response-buffer-to-elfeed-feed craftering :tags (cdar gco-opml-list)) 216 ;; (setq debian-planet (url-retrieve-synchronously (caadr gco-opml-list))) 217 ;; (gco--response-buffer-to-elfeed-feed debian-planet :tags (cdadr gco-opml-list)) 218 219 (provide 'get-craftering-opml) 220 221 ;; Local Variables: 222 ;; read-symbol-shorthands: (("gco-" . "get-craftering-opml-")) 223 ;; End: 224 ;;; get-craftering-opml.el ends here