common.scm (10938B)
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 protected INTEGER DEFAULT 0, ptime INTEGER, 64 ctime INTEGER NOT NULL DEFAULT CURRENT_TIMESTAMP, 65 mtime INTEGER NOT NULL DEFAULT CURRENT_TIMESTAMP);" 66 "CREATE TABLE tagrel (url_id REFERENCES entry(id) 67 ON UPDATE CASCADE ON DELETE CASCADE, 68 tag_id REFERENCES tag(id) 69 ON UPDATE CASCADE ON DELETE CASCADE);" 70 "CREATE TABLE feed (id INTEGER PRIMARY KEY, filename TEXT NOT NULL, 71 url TEXT NOT NULL, selector TEXT NOT NULL, 72 title TEXT NOT NULL, 73 active INTEGER NOT NULL DEFAULT 1, 74 mtime INTEGER);" 75 "CREATE TABLE selector (id INTEGER PRIMARY KEY, text TEXT);" 76 "CREATE INDEX i_mtime ON entry(mtime);" 77 "CREATE INDEX i_pmtime ON entry(protected,mtime);" 78 "CREATE UNIQUE INDEX i_url ON entry(url);" 79 "CREATE UNIQUE INDEX i_tag ON tag(name);" 80 "CREATE UNIQUE INDEX i_rel0 ON tagrel(url_id,tag_id);" 81 "CREATE INDEX i_rel1 ON tagrel(url_id);" 82 "CREATE INDEX i_rel2 ON tagrel(tag_id);" 83 "CREATE TABLE gruik 84 (id INTEGER PRIMARY KEY, 85 position INTEGER NOT NULL, 86 notes TEXT NOT NULL, 87 description TEXT, 88 ptime INTEGER NOT NULL, 89 section TEXT NOT NULL, 90 title TEXT NOT NULL, 91 url TEXT NOT NULL, 92 comment_url TEXT, 93 mark INTEGER NOT NULL DEFAULT 0, 94 ctime INTEGER NOT NULL, 95 mtime INTEGER NOT NULL, 96 stime INTEGER, 97 entry_id INTEGER REFERENCES entry(id));" 98 "CREATE UNIQUE INDEX i_gruik ON gruik(position);" 99 "CREATE INDEX i_gruik_time ON gruik(ptime);" 100 "CREATE INDEX i_gruik_url ON gruik(url);" 101 "CREATE TABLE gruik_tags 102 (gruik_id REFERENCES gruik(id) ON UPDATE CASCADE ON DELETE CASCADE, 103 tag_id REFERENCES tag(id) ON UPDATE CASCADE ON DELETE CASCADE);" 104 "CREATE UNIQUE INDEX i_gruik_rel ON gruik_tags(gruik_id,tag_id);" 105 "CREATE INDEX i_gruik_tags ON gruik_tags(tag_id,gruik_id);" 106 "CREATE TABLE source_rss 107 (id INTEGER PRIMARY KEY, 108 name TEXT NOT NULL, 109 url TEXT NOT NULL);" 110 "CREATE UNIQUE INDEX i_source_rss ON source_rss(name);" 111 "PRAGMA user_version = 4;"))) 112 113 (when (= 0 (db-version)) 114 (write-line "Updating database schema from v0 to v1") 115 (assert (= 1 (query fetch-value 116 (sql db "SELECT val FROM config WHERE key = ?;") 117 "schema-version"))) 118 (for-each 119 (lambda (s) (exec (sql/transient db s))) 120 (list "CREATE TABLE IF NOT EXISTS 121 selector (id INTEGER PRIMARY KEY, text TEXT);" 122 "DELETE FROM config WHERE key='schema-version';" 123 "PRAGMA user_version = 1;"))) 124 125 (when (= 1 (db-version)) 126 (write-line "Updating database schema from v1 to v2") 127 (for-each 128 (lambda (s) (exec (sql/transient db s))) 129 (list "ALTER TABLE feed ADD COLUMN mtime INTEGER;" 130 "PRAGMA user_version = 2;"))) 131 132 (when (= 2 (db-version)) 133 (for-each 134 (lambda (s) (exec (sql/transient db s))) 135 (list "CREATE TABLE gruik 136 (id INTEGER PRIMARY KEY, 137 position INTEGER NOT NULL, 138 notes TEXT NOT NULL, 139 description TEXT, 140 ptime INTEGER NOT NULL, 141 section TEXT NOT NULL, 142 title TEXT NOT NULL, 143 url TEXT NOT NULL, 144 mark INTEGER NOT NULL DEFAULT 0, 145 ctime INTEGER NOT NULL, 146 mtime INTEGER NOT NULL, 147 stime INTEGER);" 148 "CREATE UNIQUE INDEX i_gruik ON gruik(position);" 149 "CREATE INDEX i_gruik_time ON gruik(ptime);" 150 "CREATE TABLE gruik_tags 151 (gruik_id REFERENCES gruik(id) ON UPDATE CASCADE ON DELETE CASCADE, 152 tag_id REFERENCES tag(id) ON UPDATE CASCADE ON DELETE CASCADE);" 153 "CREATE UNIQUE INDEX i_gruik_rel ON gruik_tags(gruik_id,tag_id);" 154 "CREATE INDEX i_gruik_tags ON gruik_tags(tag_id,gruik_id);" 155 "PRAGMA user_version = 3;"))) 156 157 (when (= 3 (db-version)) 158 (for-each 159 (lambda (s) (exec (sql/transient db s))) 160 (list "CREATE TABLE source_rss 161 (id INTEGER PRIMARY KEY, 162 name TEXT NOT NULL, 163 url TEXT NOT NULL);" 164 "CREATE UNIQUE INDEX i_source_rss ON source_rss(name);" 165 "INSERT INTO source_rss(name,url) VALUES 166 ('Hacker News','https://news.ycombinator.com/rss'), 167 ('Lobsters','https://lobste.rs/rss');" 168 "ALTER TABLE gruik ADD COLUMN entry_id INTEGER REFERENCES entry(id);" 169 "PRAGMA user_version = 4;"))) 170 171 (when (= 4 (db-version)) 172 (for-each 173 (lambda (s) (exec (sql/transient db s))) 174 (list "CREATE INDEX i_gruik_url ON gruik(url);" 175 "ALTER TABLE gruik ADD COLUMN comment_url TEXT;" 176 "UPDATE gruik 177 SET comment_url=substr(notes,instr(notes,'https://news.ycombinator.com')) 178 WHERE notes LIKE '%https://news.ycombinator.com%';" 179 "UPDATE gruik 180 SET comment_url=substr(notes,instr(notes,'https://lobste.rs')) 181 WHERE notes LIKE '%https://lobste.rs%';" 182 "UPDATE gruik SET mark=-10 WHERE mark=-1;" 183 "PRAGMA user_version = 5;"))) 184 185 ;;;;;;;;;;;;;;;;;;;;;;;;; 186 ;; Database Utilitities 187 188 (define (get-config key) 189 (query fetch-value (sql db "SELECT val FROM config WHERE key = ?;") key)) 190 191 (define (get-config/default key default-value) 192 (let ((result (get-config key))) 193 (if result 194 result 195 default-value))) 196 197 ;;;;;;;;;;;;;;;;;;;; 198 ;; Feed Generation 199 200 (define (atom-content type descr notes) 201 (cond ((null? descr) `(atom:content ,notes)) 202 ((null? type) `(atom:content ,descr)) 203 ((equal? type "markdown-li") 204 (let ((acc (open-output-string)) 205 (prev-output (current-output-port))) 206 (current-output-port acc) 207 (let ((result (markdown->html (substring descr 3)))) 208 (current-output-port prev-output) 209 (if result 210 `(atom:content (@ (type "html")) ,(get-output-string acc)) 211 `(atom:content ,descr))))) 212 (else `(atom:content (@ (type ,type)) ,descr)))) 213 214 (define (feed->sxml entry-id-prefix id url type descr notes ptime ctime mtime) 215 `(atom:entry 216 (atom:id ,(string-append entry-id-prefix (number->string id))) 217 (atom:title ,url) 218 (atom:updated ,(rfc-3339 mtime)) 219 (atom:published ,(rfc-3339 (if (null? ptime) ctime ptime))) 220 (atom:link (@ (rel "related") (href ,url))) 221 ,(atom-content type descr notes) 222 ,@(query (map-rows (lambda (x) `(atom:category (@ (term ,(car x)))))) 223 (sql db "SELECT tag.name FROM tagrel 224 OUTER LEFT JOIN tag ON tagrel.tag_id=tag.id 225 WHERE url_id=? ORDER BY tag.name;") 226 id))) 227 228 (define (optional-feed-element key value) 229 (if value (list (list key value)) '())) 230 231 (define (write-feed mtime title self rows) 232 (let ((author-name (get-config/default "author-name" "Unknown Author")) 233 (author-email (get-config "author-email")) 234 (author-uri (get-config "author-uri")) 235 (id-prefix (get-config/default "entry-id-prefix" ""))) 236 (write-string 237 (serialize-sxml 238 `(*TOP* (@ (*NAMESPACES* (atom "http://www.w3.org/2005/Atom"))) 239 (*PI* xml "version='1.0' encoding='utf-8'") 240 (atom:feed 241 (atom:title ,title) 242 (atom:author 243 (atom:name ,author-name) 244 ,@(optional-feed-element 'atom:email author-email) 245 ,@(optional-feed-element 'atom:uri author-uri)) 246 (atom:id ,self) 247 (atom:link (@ (rel "self") (href ,self))) 248 (atom:updated ,(rfc-3339 mtime)) 249 ,@(map (lambda (r) (apply feed->sxml (cons id-prefix r))) rows))) 250 ns-prefixes: '((*default* . "http://www.w3.org/2005/Atom")))))) 251 252 (define (feed-rows selector) 253 (query fetch-rows 254 (sql/transient db (string-append "SELECT id,url,type,description, 255 notes,ptime,ctime,mtime 256 FROM entry " selector ";"))))