common.scm (14822B)
1 ; Copyright (c) 2023-2026, Natacha Porté 2 ; 3 ; Permission to use, copy, modify, and distribute this software for any 4 ; purpose with or without fee is hereby granted, provided that the above 5 ; copyright notice and this permission notice appear in all copies. 6 ; 7 ; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 ; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 ; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 ; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 ; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 ; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 ; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 15 ;;;;;;;;;;;;;;;;;;; 16 ;; Misc Utilities 17 18 (define (comment-link section url) 19 (let* ((rss-url (query fetch-value 20 (sql db "SELECT url FROM source_rss WHERE name=?;") 21 section))) 22 (if rss-url 23 (let ((rss (with-input-from-request rss-url #f rss:read))) 24 (let loop ((items (rss:feed-items rss))) 25 (cond 26 ((null? items) #f) 27 ((string=? url (rss:item-link (car items))) 28 (alist-ref 'comments (rss:item-attributes (car items)))) 29 (else (loop (cdr items)))))) 30 #f))) 31 32 (define (time->rfc-3339 time) 33 (let ((time-str (time->string time "%FT%T%z"))) 34 (assert (= 24 (string-length time-str))) 35 (if (equal? "0000" (substring time-str 20)) 36 (string-append (substring time-str 0 19) "Z") 37 (string-append (substring time-str 0 22) 38 ":" 39 (substring time-str 22))))) 40 41 (define (rfc-3339-local seconds) 42 (time->rfc-3339 (seconds->local-time seconds))) 43 (define (rfc-3339-utc seconds) 44 (time->rfc-3339 (seconds->utc-time seconds))) 45 (define rfc-3339 rfc-3339-local) 46 47 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 48 ;; Database Creation/Migration 49 50 (define (db-version) 51 (query fetch-value (sql db "PRAGMA user_version;"))) 52 53 (when (= 0 (db-version)) 54 (write-line "Initializing database with schema v8") 55 (for-each 56 (lambda (s) (exec (sql/transient db s))) 57 (list "CREATE TABLE config (key TEXT PRIMARY KEY, val);" 58 "CREATE TABLE tag (id INTEGER PRIMARY KEY, 59 name TEXT NOT NULL, 60 auto INTEGER DEFAULT 0);" 61 "CREATE TABLE entry (id INTEGER PRIMARY KEY, 62 url TEXT NOT NULL, type TEXT, description TEXT, notes TEXT, 63 title TEXT, section TEXT, section_url TEXT, 64 protected INTEGER DEFAULT 0, ptime INTEGER, 65 ctime INTEGER NOT NULL DEFAULT CURRENT_TIMESTAMP, 66 mtime INTEGER NOT NULL DEFAULT CURRENT_TIMESTAMP);" 67 "CREATE TABLE tagrel (url_id REFERENCES entry(id) 68 ON UPDATE CASCADE ON DELETE CASCADE, 69 tag_id REFERENCES tag(id) 70 ON UPDATE CASCADE ON DELETE CASCADE);" 71 "CREATE TABLE feed (id INTEGER PRIMARY KEY, filename TEXT NOT NULL, 72 url TEXT NOT NULL, selector TEXT NOT NULL, 73 title TEXT NOT NULL, 74 active INTEGER NOT NULL DEFAULT 1, 75 mtime INTEGER);" 76 "CREATE TABLE selector (id INTEGER PRIMARY KEY, text TEXT);" 77 "CREATE INDEX i_mtime ON entry(mtime);" 78 "CREATE INDEX i_pmtime ON entry(protected,mtime);" 79 "CREATE UNIQUE INDEX i_url ON entry(url);" 80 "CREATE UNIQUE INDEX i_tag ON tag(name);" 81 "CREATE UNIQUE INDEX i_rel0 ON tagrel(url_id,tag_id);" 82 "CREATE INDEX i_rel1 ON tagrel(url_id);" 83 "CREATE INDEX i_rel2 ON tagrel(tag_id);" 84 "CREATE TABLE gruik 85 (id INTEGER PRIMARY KEY, 86 position INTEGER NOT NULL, 87 notes TEXT NOT NULL, 88 description TEXT, 89 ptime INTEGER NOT NULL, 90 section TEXT NOT NULL, 91 title TEXT NOT NULL, 92 url TEXT NOT NULL, 93 comment_url TEXT, 94 mark INTEGER NOT NULL DEFAULT 0, 95 ctime INTEGER NOT NULL, 96 mtime INTEGER NOT NULL, 97 stime INTEGER, 98 lastseen INTEGER, 99 entry_id INTEGER REFERENCES entry(id));" 100 "CREATE UNIQUE INDEX i_gruik ON gruik(position) WHERE position > 0;" 101 "CREATE INDEX i_gruik_mtime ON gruik(mtime);" 102 "CREATE INDEX i_gruik_time ON gruik(ptime);" 103 "CREATE INDEX i_gruik_url ON gruik(url);" 104 "CREATE TABLE gruik_tags 105 (gruik_id REFERENCES gruik(id) ON UPDATE CASCADE ON DELETE CASCADE, 106 tag_id REFERENCES tag(id) ON UPDATE CASCADE ON DELETE CASCADE);" 107 "CREATE UNIQUE INDEX i_gruik_rel ON gruik_tags(gruik_id,tag_id);" 108 "CREATE INDEX i_gruik_tags ON gruik_tags(tag_id,gruik_id);" 109 "CREATE TABLE source_rss 110 (id INTEGER PRIMARY KEY, 111 name TEXT NOT NULL, 112 url TEXT NOT NULL, 113 format INTEGER NOT NULL DEFAULT 0, 114 last_modified INTEGER, 115 etag TEXT);" 116 "CREATE UNIQUE INDEX i_source_rss ON source_rss(name);" 117 "PRAGMA user_version = 8;"))) 118 119 (when (= 1 (db-version)) 120 (write-line "Updating database schema from v1 to v2") 121 (for-each 122 (lambda (s) (exec (sql/transient db s))) 123 (list "ALTER TABLE feed ADD COLUMN mtime INTEGER;" 124 "PRAGMA user_version = 2;"))) 125 126 (when (= 2 (db-version)) 127 (for-each 128 (lambda (s) (exec (sql/transient db s))) 129 (list "CREATE TABLE gruik 130 (id INTEGER PRIMARY KEY, 131 position INTEGER NOT NULL, 132 notes TEXT NOT NULL, 133 description TEXT, 134 ptime INTEGER NOT NULL, 135 section TEXT NOT NULL, 136 title TEXT NOT NULL, 137 url TEXT NOT NULL, 138 mark INTEGER NOT NULL DEFAULT 0, 139 ctime INTEGER NOT NULL, 140 mtime INTEGER NOT NULL, 141 stime INTEGER);" 142 "CREATE UNIQUE INDEX i_gruik ON gruik(position);" 143 "CREATE INDEX i_gruik_time ON gruik(ptime);" 144 "CREATE TABLE gruik_tags 145 (gruik_id REFERENCES gruik(id) ON UPDATE CASCADE ON DELETE CASCADE, 146 tag_id REFERENCES tag(id) ON UPDATE CASCADE ON DELETE CASCADE);" 147 "CREATE UNIQUE INDEX i_gruik_rel ON gruik_tags(gruik_id,tag_id);" 148 "CREATE INDEX i_gruik_tags ON gruik_tags(tag_id,gruik_id);" 149 "PRAGMA user_version = 3;"))) 150 151 (when (= 3 (db-version)) 152 (for-each 153 (lambda (s) (exec (sql/transient db s))) 154 (list "CREATE TABLE source_rss 155 (id INTEGER PRIMARY KEY, 156 name TEXT NOT NULL, 157 url TEXT NOT NULL);" 158 "CREATE UNIQUE INDEX i_source_rss ON source_rss(name);" 159 "INSERT INTO source_rss(name,url) VALUES 160 ('Hacker News','https://news.ycombinator.com/rss'), 161 ('Lobsters','https://lobste.rs/rss');" 162 "ALTER TABLE gruik ADD COLUMN entry_id INTEGER REFERENCES entry(id);" 163 "PRAGMA user_version = 4;"))) 164 165 (when (= 4 (db-version)) 166 (for-each 167 (lambda (s) (exec (sql/transient db s))) 168 (list "CREATE INDEX i_gruik_url ON gruik(url);" 169 "ALTER TABLE gruik ADD COLUMN comment_url TEXT;" 170 "UPDATE gruik 171 SET comment_url=substr(notes,instr(notes,'https://news.ycombinator.com')) 172 WHERE notes LIKE '%https://news.ycombinator.com%';" 173 "UPDATE gruik 174 SET comment_url=substr(notes,instr(notes,'https://lobste.rs')) 175 WHERE notes LIKE '%https://lobste.rs%';" 176 "UPDATE gruik SET mark=-10 WHERE mark=-1;" 177 "PRAGMA user_version = 5;"))) 178 179 (when (= 5 (db-version)) 180 (for-each 181 (lambda (s) (exec (sql/transient db s))) 182 (list "ALTER TABLE selector ADD COLUMN name TEXT;" 183 "UPDATE selector SET name = text;" 184 "PRAGMA user_version = 6;"))) 185 186 (when (= 6 (db-version)) 187 (with-transaction db 188 (lambda () 189 (for-each 190 (lambda (s) (exec (sql/transient db s))) 191 (list 192 "ALTER TABLE entry ADD COLUMN title TEXT;" 193 "ALTER TABLE entry ADD COLUMN source TEXT;" 194 "ALTER TABLE entry ADD COLUMN source_url TEXT;" 195 "UPDATE entry 196 SET title=rtrim(substr(notes, 197 instr(notes,']')+2, 198 instr(notes,'://')-instr(notes,']')-7), 199 ' '||CHAR(10)), 200 source=substr(notes, 201 instr(notes,'[')+1, 202 instr(notes,']')-instr(notes,'[')-1) 203 WHERE notes GLOB '*ruikBot*';" 204 ; WHERE notes REGEXP '^[0-9.: <]*[GMN]ruikBot_?> \\[[^]]*\\]';" 205 "UPDATE entry SET source=substr(source,1,instr(source,':')-1) 206 WHERE instr(source,':')>0;" 207 "UPDATE entry SET source=substr(source,1,instr(source,' - ')-1) 208 WHERE instr(source,' - ')>0;" 209 "UPDATE entry 210 SET source_url=substr(description, 211 instr(description,'via ['||source||'](')) 212 WHERE instr(description,'via ['||source||'](')>0 213 AND description 214 GLOB '*(via [[]'||source||'[]](*) [Ss]ur #gcuf[fe]ed[f)]?' 215 AND description 216 NOT GLOB '*(via [[]'||source||'[]](*)*) sur #gcufeed)?';" 217 ; AND description REGEXP '\\(via \\['||source||'\\]\\([^\\)]*\\) ([Ss]ur |via )?#g(cu|uc)f[fe]e?ed[f)]?';" 218 "UPDATE entry 219 SET source_url=substr(source_url, 220 instr(source_url,'(')+1, 221 instr(source_url,')')-instr(source_url,'(')-1) 222 WHERE source_url IS NOT NULL;" 223 "PRAGMA user_version = 7;"))))) 224 225 (when (= 7 (db-version)) 226 (with-transaction db 227 (lambda () 228 (for-each 229 (lambda (s) (exec (sql/transient db s))) 230 (list 231 "CREATE INDEX i_gruik_mtime ON gruik(mtime);" 232 "DROP INDEX i_gruik;" 233 "CREATE UNIQUE INDEX i_gruik ON gruik(position) WHERE position > 0;" 234 "CREATE INDEX i_gruik_section ON gruik(section);" 235 "ALTER TABLE source_rss ADD COLUMN format INTEGER NOT NULL DEFAULT 0;" 236 "ALTER TABLE source_rss ADD COLUMN last_modified INTEGER;" 237 "ALTER TABLE source_rss ADD COLUMN etag TEXT;" 238 "ALTER TABLE gruik ADD COLUMN lastseen INTEGER;" 239 "PRAGMA user_version = 8;"))))) 240 241 ;;;;;;;;;;;;;;;;;;;;;;;;; 242 ;; Database Utilitities 243 244 (define (get-config key) 245 (query fetch-value (sql db "SELECT val FROM config WHERE key = ?;") key)) 246 247 (define (get-config/default key default-value) 248 (let ((result (get-config key))) 249 (if result 250 result 251 default-value))) 252 253 ;;;;;;;;;;;;;;;;;;;; 254 ;; Feed Generation 255 256 (define (atom-content type descr notes) 257 (cond ((null? descr) `(atom:content ,notes)) 258 ((null? type) `(atom:content ,descr)) 259 ((equal? type "markdown-li") 260 (let ((acc (open-output-string)) 261 (prev-output (current-output-port))) 262 (current-output-port acc) 263 (let ((result (markdown->html (substring descr 3)))) 264 (current-output-port prev-output) 265 (if result 266 `(atom:content (@ (type "html")) ,(get-output-string acc)) 267 `(atom:content ,descr))))) 268 (else `(atom:content (@ (type ,type)) ,descr)))) 269 270 (define (feed->sxml entry-id-prefix id url type descr notes ptime ctime mtime) 271 `(atom:entry 272 (atom:id ,(string-append entry-id-prefix (number->string id))) 273 (atom:title ,url) 274 (atom:updated ,(rfc-3339 mtime)) 275 (atom:published ,(rfc-3339 (if (null? ptime) ctime ptime))) 276 (atom:link (@ (rel "related") (href ,url))) 277 ,(atom-content type descr notes) 278 ,@(query (map-rows (lambda (x) `(atom:category (@ (term ,(car x)))))) 279 (sql db "SELECT tag.name FROM tagrel 280 OUTER LEFT JOIN tag ON tagrel.tag_id=tag.id 281 WHERE url_id=? ORDER BY tag.name;") 282 id))) 283 284 (define (optional-feed-element key value) 285 (if value (list (list key value)) '())) 286 287 (define (write-feed mtime title self rows) 288 (let ((author-name (get-config/default "author-name" "Unknown Author")) 289 (author-email (get-config "author-email")) 290 (author-uri (get-config "author-uri")) 291 (id-prefix (get-config/default "entry-id-prefix" ""))) 292 (write-string 293 (serialize-sxml 294 `(*TOP* (@ (*NAMESPACES* (atom "http://www.w3.org/2005/Atom"))) 295 (*PI* xml "version='1.0' encoding='utf-8'") 296 (atom:feed 297 (atom:title ,title) 298 (atom:author 299 (atom:name ,author-name) 300 ,@(optional-feed-element 'atom:email author-email) 301 ,@(optional-feed-element 'atom:uri author-uri)) 302 (atom:id ,self) 303 (atom:link (@ (rel "self") (href ,self))) 304 (atom:updated ,(rfc-3339 mtime)) 305 ,@(map (lambda (r) (apply feed->sxml (cons id-prefix r))) rows))) 306 ns-prefixes: '((*default* . "http://www.w3.org/2005/Atom")))))) 307 308 (define (feed-rows selector) 309 (query fetch-rows 310 (sql/transient db (string-append "SELECT id,url,type,description, 311 notes,ptime,ctime,mtime 312 FROM entry " selector ";")))) 313 314 ;;;;;;;;;;;;;;;;;;; 315 ;; Feed Utilities 316 317 (define (build-signature selector) 318 (query fetch-rows 319 (sql db (string-append "SELECT id,mtime FROM entry " selector ";")))) 320 321 (define (car< a b) (< (car a) (car b))) 322 323 (define (diff-signature old-sig new-sig) 324 (let loop ((old (sort old-sig car<)) 325 (new (sort new-sig car<)) 326 (result '())) 327 (cond ((and (null? old) (null? new)) 328 result) 329 ((null? old) 330 (loop old 331 (cdr new) 332 (cons `(add ,@(car new)) result))) 333 ((null? new) 334 (loop (cdr old) 335 new 336 (cons `(del ,@(car old)) result))) 337 ((equal? (car new) (car old)) 338 (loop (cdr old) 339 (cdr new) 340 result)) 341 ((= (caar new) (caar old)) 342 (loop (cdr old) 343 (cdr new) 344 (cons `(chg ,@(car old) ,(cadar new)) result))) 345 ((< (caar new) (caar old)) 346 (loop old 347 (cdr new) 348 (cons `(add ,@(car new)) result))) 349 ((> (caar new) (caar old)) 350 (loop (cdr old) 351 new 352 (cons `(del ,@(car old)) result))) 353 (else (assert #f "Should be unreachable")))))