get-gruiks.scm (10159B)
1 ; Copyright (c) 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 (import 16 (chicken condition) 17 (chicken io) 18 (chicken port) 19 (chicken process signal) 20 (chicken process-context) 21 (chicken string) 22 (chicken time) 23 (chicken time posix) 24 atom 25 openssl ; must be above http-client 26 http-client 27 intarweb 28 nanosleep 29 rss 30 sql-de-lite 31 uri-common) 32 33 ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 34 ;; Command-Line Processing 35 36 (define arg-list (command-line-arguments)) 37 38 (define db-name 39 (if (>= (length arg-list) 1) 40 (car arg-list) 41 "iens.sqlite")) 42 43 (define total-period 44 (if (>= (length arg-list) 2) 45 (string->number (list-ref arg-list 1)) 46 #f)) 47 48 ;;;;;;;;;;;;;;;;;;;;;;; 49 ;; Persistent Storage 50 51 (define db 52 (open-database db-name)) 53 (exec (sql/transient db "PRAGMA foreign_keys = ON; 54 PRAGMA journal_mode = WAL; 55 PRAGMA synchronous = NORMAL; 56 PRAGMA busy_timeout = 5000;")) 57 (set-busy-handler! db (busy-timeout 10000)) 58 59 (include "common.scm") 60 61 (assert (= 8 (db-version))) 62 63 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 64 ;; Gruik build from sources 65 66 (define (process-gruik source url title comm) 67 (when (= 0 (exec (sql db "UPDATE gruik 68 SET lastseen=CAST(strftime('%s', 'now') as INT), 69 comment_url=? 70 WHERE section=? AND url=? AND title=? 71 AND (comment_url IS NULL OR comment_url=?1);") 72 (if comm comm '()) source url title) 73 (query fetch-value 74 (sql db "SELECT count(id) FROM entry 75 WHERE source=? AND url=? AND title=?;") 76 source url title)) 77 (when (= 0 (exec (sql db "UPDATE gruik 78 SET title=?, 79 comment_url=?, 80 notes=trim(notes||char(10) 81 ||'Previously “'||title||'”', 82 char(10)), 83 lastseen=CAST(strftime('%s', 'now') AS INT) 84 WHERE url=? AND section=? 85 AND (comment_url IS NULL OR comment_url=?2);") 86 title (if comm comm '()) url source)) 87 (exec 88 (sql db "INSERT INTO gruik(position, notes, ptime, 89 section, url, title, comment_url, 90 mark, ctime, mtime, lastseen) 91 VALUES (-1, '', datetime(?1,'unixepoch')||'*', 92 ?2, ?3, ?4, ?5, 93 ?6, ?1, ?1, CAST(strftime('%s', 'now') as INT));") 94 (query fetch-value 95 (sql db "SELECT MAX(CAST(strftime('%s', 'now') as INT), 96 (SELECT max(mtime) FROM gruik) + 1);")) 97 source url title (if comm comm '()) 98 (if (= 0 (query fetch-value 99 (sql db "SELECT count(id) FROM gruik WHERE url=?;") 100 url) 101 (query fetch-value 102 (sql db "SELECT count(id) FROM entry WHERE url=?;") 103 url)) 104 0 -1))))) 105 106 (define (process-atom source items) 107 (unless (null? items) 108 (process-gruik source 109 (link-uri (car (entry-links (car items)))) 110 (title-text (entry-title (car items))) 111 #f) 112 (process-atom source (cdr items)))) 113 114 (define (process-rss source items) 115 (unless (null? items) 116 (let* ((item (car items)) 117 (attr (rss:item-attributes item)) 118 (link (rss:item-link item)) 119 (title (rss:item-title item)) 120 (comm (alist-ref 'comments attr))) 121 (process-gruik source link (if title title link) comm) 122 (process-rss source (cdr items))))) 123 124 (define (absorb-304 req parse) 125 (condition-case 126 (with-input-from-request req #f parse) 127 ((exn unexpected-server-response) (values #f #f #f)))) 128 129 (define (get-source parse url last-modified etag) 130 (let* ((hlm (if (null? last-modified) '() 131 `((if-modified-since 132 #(,(seconds->local-time last-modified) ()))))) 133 (het (cond ((null? etag) '()) 134 ((string=? etag "") '()) 135 ((eqv? (string-ref etag 0) #\S) 136 `((if-none-match (strong . ,(substring etag 1))))) 137 ((eqv? (string-ref etag 0) #\W) 138 `((if-none-match (weak . ,(substring etag 1))))) 139 (else '()))) 140 (req (make-request 141 uri: (uri-reference url) 142 headers: (headers `(,@hlm ,@het))))) 143 (let-values (((result _ resp) (absorb-304 req parse))) 144 (when resp 145 (let* ((hdr (response-headers resp)) 146 (lm (header-value 'last-modified hdr)) 147 (et (header-value 'etag hdr))) 148 (when (or (not (null? last-modified)) (not (null? etag)) lm et) 149 (exec (sql db "UPDATE source_rss SET last_modified=?, etag=? 150 WHERE url=?;") 151 (if lm (local-time->seconds lm) '()) 152 (if et (string-append 153 (cond ((eq? (car et) 'weak) "W") 154 ((eq? (car et) 'strong) "S") 155 (else "*")) 156 (cdr et)) 157 '()) 158 url)))) 159 result))) 160 161 (define (atom:read) (read-atom-feed (current-input-port))) 162 (define (get-atom url last-modified etag) 163 (let ((feed (get-source atom:read url last-modified etag))) 164 (if feed 165 (list 1 166 (feed-entries feed) 167 (title-text (feed-title feed))) 168 #f))) 169 170 (define (get-rss url last-modified etag) 171 (let ((feed (get-source rss:read url last-modified etag))) 172 (if feed 173 (list 2 174 (rss:feed-items feed) 175 (rss:item-title (rss:feed-channel feed))) 176 #f))) 177 178 (define (get-auto url) 179 (let* ((data (get-source read-string url '() '())) 180 (da (condition-case (with-input-from-string data atom:read) 181 ((atom) #f))) 182 (dr (condition-case (with-input-from-string data rss:read) 183 ((rss) #f)))) 184 (exec (sql db "UPDATE source_rss SET format=? WHERE url=?;") 185 (cond (da 1) (dr 2) (else -1)) 186 url) 187 (cond 188 (da (list 1 189 (feed-entries da) 190 (title-text (feed-title da)))) 191 (dr (list 2 192 (rss:feed-items dr) 193 (rss:item-title (rss:feed-channel dr)))) 194 (else #f)))) 195 196 (define (process-source name url format last-modified etag) 197 (condition-case 198 (let ((data (case format ((0) (get-auto url)) 199 ((1) (get-atom url last-modified etag)) 200 ((2) (get-rss url last-modified etag)) 201 (else #f)))) 202 (if data 203 (let ((args (list 204 (if (string=? name url) 205 (begin 206 (exec (sql db "UPDATE source_rss SET name=? 207 WHERE name=? AND url=?;") 208 (caddr data) name url) 209 (caddr data)) 210 name) 211 (cadr data)))) 212 (case (car data) 213 ((1) (apply process-atom args)) 214 ((2) (apply process-rss args)) 215 (else (assert #f "Bad process index")))) 216 (exec (sql db "UPDATE gruik 217 SET lastseen=CAST(strftime('%s', 'now') as INT) 218 WHERE section=?;") 219 name))) 220 (exn (client-error) 221 (write-line (conc "Error while checking " name)) 222 (write-line (conc " Headers: " (response-headers ((condition-property-accessor 'client-error 'response) exn)))) 223 (print-error-message exn)) 224 (exn (user-interrupt) (signal exn)) 225 (exn () (write-line (conc "Error while checking " name)) 226 (print-error-message exn)))) 227 228 ;;;;;;;;;;;;;;; 229 ;; Actual Run 230 231 (define (add-period prev-deadline) 232 (+ (max prev-deadline (current-seconds)) 233 (/ total-period 234 (query fetch-value (sql db "SELECT count(*) FROM source_rss;"))))) 235 236 (define usr1-queue (make-signal-handler signal/usr1)) 237 238 (if total-period 239 (let loop ((index (query fetch-value 240 (sql/transient db 241 "SELECT min(id) FROM source_rss;"))) 242 (deadline (add-period 0))) 243 (let ((arg (query fetch-row 244 (sql db "SELECT 245 COALESCE((SELECT min(id) FROM source_rss 246 WHERE id > ?1), 247 (SELECT min(id) FROM source_rss)), 248 name,url,format,last_modified,etag 249 FROM source_rss WHERE id = ?1;") 250 index))) 251 (apply process-source (cdr arg)) 252 (let ((rest (- deadline (current-seconds)))) 253 (when (positive? rest) 254 (secosleep rest))) 255 (unless (and (<= (car arg) index) (usr1-queue)) 256 (loop (car arg) (add-period deadline))))) 257 (query 258 (for-each-row* process-source) 259 (sql db "SELECT name,url,format,last_modified,etag FROM source_rss;")))