common.scm (15306B)
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 (null? (schema db)) 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 (= 0 (db-version)) 120 (write-line "Updating database schema from v0 to v1") 121 (assert (= 1 (query fetch-value 122 (sql db "SELECT val FROM config WHERE key = ?;") 123 "schema-version"))) 124 (for-each 125 (lambda (s) (exec (sql/transient db s))) 126 (list "CREATE TABLE IF NOT EXISTS 127 selector (id INTEGER PRIMARY KEY, text TEXT);" 128 "DELETE FROM config WHERE key='schema-version';" 129 "PRAGMA user_version = 1;"))) 130 131 (when (= 1 (db-version)) 132 (write-line "Updating database schema from v1 to v2") 133 (for-each 134 (lambda (s) (exec (sql/transient db s))) 135 (list "ALTER TABLE feed ADD COLUMN mtime INTEGER;" 136 "PRAGMA user_version = 2;"))) 137 138 (when (= 2 (db-version)) 139 (for-each 140 (lambda (s) (exec (sql/transient db s))) 141 (list "CREATE TABLE gruik 142 (id INTEGER PRIMARY KEY, 143 position INTEGER NOT NULL, 144 notes TEXT NOT NULL, 145 description TEXT, 146 ptime INTEGER NOT NULL, 147 section TEXT NOT NULL, 148 title TEXT NOT NULL, 149 url TEXT NOT NULL, 150 mark INTEGER NOT NULL DEFAULT 0, 151 ctime INTEGER NOT NULL, 152 mtime INTEGER NOT NULL, 153 stime INTEGER);" 154 "CREATE UNIQUE INDEX i_gruik ON gruik(position);" 155 "CREATE INDEX i_gruik_time ON gruik(ptime);" 156 "CREATE TABLE gruik_tags 157 (gruik_id REFERENCES gruik(id) ON UPDATE CASCADE ON DELETE CASCADE, 158 tag_id REFERENCES tag(id) ON UPDATE CASCADE ON DELETE CASCADE);" 159 "CREATE UNIQUE INDEX i_gruik_rel ON gruik_tags(gruik_id,tag_id);" 160 "CREATE INDEX i_gruik_tags ON gruik_tags(tag_id,gruik_id);" 161 "PRAGMA user_version = 3;"))) 162 163 (when (= 3 (db-version)) 164 (for-each 165 (lambda (s) (exec (sql/transient db s))) 166 (list "CREATE TABLE source_rss 167 (id INTEGER PRIMARY KEY, 168 name TEXT NOT NULL, 169 url TEXT NOT NULL);" 170 "CREATE UNIQUE INDEX i_source_rss ON source_rss(name);" 171 "INSERT INTO source_rss(name,url) VALUES 172 ('Hacker News','https://news.ycombinator.com/rss'), 173 ('Lobsters','https://lobste.rs/rss');" 174 "ALTER TABLE gruik ADD COLUMN entry_id INTEGER REFERENCES entry(id);" 175 "PRAGMA user_version = 4;"))) 176 177 (when (= 4 (db-version)) 178 (for-each 179 (lambda (s) (exec (sql/transient db s))) 180 (list "CREATE INDEX i_gruik_url ON gruik(url);" 181 "ALTER TABLE gruik ADD COLUMN comment_url TEXT;" 182 "UPDATE gruik 183 SET comment_url=substr(notes,instr(notes,'https://news.ycombinator.com')) 184 WHERE notes LIKE '%https://news.ycombinator.com%';" 185 "UPDATE gruik 186 SET comment_url=substr(notes,instr(notes,'https://lobste.rs')) 187 WHERE notes LIKE '%https://lobste.rs%';" 188 "UPDATE gruik SET mark=-10 WHERE mark=-1;" 189 "PRAGMA user_version = 5;"))) 190 191 (when (= 5 (db-version)) 192 (for-each 193 (lambda (s) (exec (sql/transient db s))) 194 (list "ALTER TABLE selector ADD COLUMN name TEXT;" 195 "UPDATE selector SET name = text;" 196 "PRAGMA user_version = 6;"))) 197 198 (when (= 6 (db-version)) 199 (with-transaction db 200 (lambda () 201 (for-each 202 (lambda (s) (exec (sql/transient db s))) 203 (list 204 "ALTER TABLE entry ADD COLUMN title TEXT;" 205 "ALTER TABLE entry ADD COLUMN source TEXT;" 206 "ALTER TABLE entry ADD COLUMN source_url TEXT;" 207 "UPDATE entry 208 SET title=rtrim(substr(notes, 209 instr(notes,']')+2, 210 instr(notes,'://')-instr(notes,']')-7), 211 ' '||CHAR(10)), 212 source=substr(notes, 213 instr(notes,'[')+1, 214 instr(notes,']')-instr(notes,'[')-1) 215 WHERE notes GLOB '*ruikBot*';" 216 ; WHERE notes REGEXP '^[0-9.: <]*[GMN]ruikBot_?> \\[[^]]*\\]';" 217 "UPDATE entry SET source=substr(source,1,instr(source,':')-1) 218 WHERE instr(source,':')>0;" 219 "UPDATE entry SET source=substr(source,1,instr(source,' - ')-1) 220 WHERE instr(source,' - ')>0;" 221 "UPDATE entry 222 SET source_url=substr(description, 223 instr(description,'via ['||source||'](')) 224 WHERE instr(description,'via ['||source||'](')>0 225 AND description 226 GLOB '*(via [[]'||source||'[]](*) [Ss]ur #gcuf[fe]ed[f)]?' 227 AND description 228 NOT GLOB '*(via [[]'||source||'[]](*)*) sur #gcufeed)?';" 229 ; AND description REGEXP '\\(via \\['||source||'\\]\\([^\\)]*\\) ([Ss]ur |via )?#g(cu|uc)f[fe]e?ed[f)]?';" 230 "UPDATE entry 231 SET source_url=substr(source_url, 232 instr(source_url,'(')+1, 233 instr(source_url,')')-instr(source_url,'(')-1) 234 WHERE source_url IS NOT NULL;" 235 "PRAGMA user_version = 7;"))))) 236 237 (when (= 7 (db-version)) 238 (with-transaction db 239 (lambda () 240 (for-each 241 (lambda (s) (exec (sql/transient db s))) 242 (list 243 "CREATE INDEX i_gruik_mtime ON gruik(mtime);" 244 "DROP INDEX i_gruik;" 245 "CREATE UNIQUE INDEX i_gruik ON gruik(position) WHERE position > 0;" 246 "CREATE INDEX i_gruik_section ON gruik(section);" 247 "ALTER TABLE source_rss ADD COLUMN format INTEGER NOT NULL DEFAULT 0;" 248 "ALTER TABLE source_rss ADD COLUMN last_modified INTEGER;" 249 "ALTER TABLE source_rss ADD COLUMN etag TEXT;" 250 "ALTER TABLE gruik ADD COLUMN lastseen INTEGER;" 251 "PRAGMA user_version = 8;"))))) 252 253 ;;;;;;;;;;;;;;;;;;;;;;;;; 254 ;; Database Utilitities 255 256 (define (get-config key) 257 (query fetch-value (sql db "SELECT val FROM config WHERE key = ?;") key)) 258 259 (define (get-config/default key default-value) 260 (let ((result (get-config key))) 261 (if result 262 result 263 default-value))) 264 265 ;;;;;;;;;;;;;;;;;;;; 266 ;; Feed Generation 267 268 (define (atom-content type descr notes) 269 (cond ((null? descr) `(atom:content ,notes)) 270 ((null? type) `(atom:content ,descr)) 271 ((equal? type "markdown-li") 272 (let ((acc (open-output-string)) 273 (prev-output (current-output-port))) 274 (current-output-port acc) 275 (let ((result (markdown->html (substring descr 3)))) 276 (current-output-port prev-output) 277 (if result 278 `(atom:content (@ (type "html")) ,(get-output-string acc)) 279 `(atom:content ,descr))))) 280 (else `(atom:content (@ (type ,type)) ,descr)))) 281 282 (define (feed->sxml entry-id-prefix id url type descr notes ptime ctime mtime) 283 `(atom:entry 284 (atom:id ,(string-append entry-id-prefix (number->string id))) 285 (atom:title ,url) 286 (atom:updated ,(rfc-3339 mtime)) 287 (atom:published ,(rfc-3339 (if (null? ptime) ctime ptime))) 288 (atom:link (@ (rel "related") (href ,url))) 289 ,(atom-content type descr notes) 290 ,@(query (map-rows (lambda (x) `(atom:category (@ (term ,(car x)))))) 291 (sql db "SELECT tag.name FROM tagrel 292 OUTER LEFT JOIN tag ON tagrel.tag_id=tag.id 293 WHERE url_id=? ORDER BY tag.name;") 294 id))) 295 296 (define (optional-feed-element key value) 297 (if value (list (list key value)) '())) 298 299 (define (write-feed mtime title self rows) 300 (let ((author-name (get-config/default "author-name" "Unknown Author")) 301 (author-email (get-config "author-email")) 302 (author-uri (get-config "author-uri")) 303 (id-prefix (get-config/default "entry-id-prefix" ""))) 304 (write-string 305 (serialize-sxml 306 `(*TOP* (@ (*NAMESPACES* (atom "http://www.w3.org/2005/Atom"))) 307 (*PI* xml "version='1.0' encoding='utf-8'") 308 (atom:feed 309 (atom:title ,title) 310 (atom:author 311 (atom:name ,author-name) 312 ,@(optional-feed-element 'atom:email author-email) 313 ,@(optional-feed-element 'atom:uri author-uri)) 314 (atom:id ,self) 315 (atom:link (@ (rel "self") (href ,self))) 316 (atom:updated ,(rfc-3339 mtime)) 317 ,@(map (lambda (r) (apply feed->sxml (cons id-prefix r))) rows))) 318 ns-prefixes: '((*default* . "http://www.w3.org/2005/Atom")))))) 319 320 (define (feed-rows selector) 321 (query fetch-rows 322 (sql/transient db (string-append "SELECT id,url,type,description, 323 notes,ptime,ctime,mtime 324 FROM entry " selector ";")))) 325 326 ;;;;;;;;;;;;;;;;;;; 327 ;; Feed Utilities 328 329 (define (build-signature selector) 330 (query fetch-rows 331 (sql db (string-append "SELECT id,mtime FROM entry " selector ";")))) 332 333 (define (car< a b) (< (car a) (car b))) 334 335 (define (diff-signature old-sig new-sig) 336 (let loop ((old (sort old-sig car<)) 337 (new (sort new-sig car<)) 338 (result '())) 339 (cond ((and (null? old) (null? new)) 340 result) 341 ((null? old) 342 (loop old 343 (cdr new) 344 (cons `(add ,@(car new)) result))) 345 ((null? new) 346 (loop (cdr old) 347 new 348 (cons `(del ,@(car old)) result))) 349 ((equal? (car new) (car old)) 350 (loop (cdr old) 351 (cdr new) 352 result)) 353 ((= (caar new) (caar old)) 354 (loop (cdr old) 355 (cdr new) 356 (cons `(chg ,@(car old) ,(cadar new)) result))) 357 ((< (caar new) (caar old)) 358 (loop old 359 (cdr new) 360 (cons `(add ,@(car new)) result))) 361 ((> (caar new) (caar old)) 362 (loop (cdr old) 363 new 364 (cons `(del ,@(car old)) result))) 365 (else (assert #f "Should be unreachable")))))