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