iens.scm (56604B)
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 (import (chicken condition) 16 (chicken file) 17 (chicken file posix) 18 (chicken io) 19 (chicken process) 20 (chicken process signal) 21 (chicken process-context) 22 (chicken sort) 23 (chicken string) 24 (chicken time) 25 (chicken time posix) 26 breadline 27 breadline-scheme-completion 28 http-client 29 lowdown 30 ncurses 31 rss 32 sql-de-lite 33 srfi-1 34 sxml-serializer) 35 36 (define (starts-with? maybe-prefix s) 37 (and (<= (string-length maybe-prefix) (string-length s)) 38 (substring=? s maybe-prefix 0 0 (string-length maybe-prefix)))) 39 40 (define (ends-with? maybe-suffix s) 41 (let ((ls (string-length s)) 42 (lms (string-length maybe-suffix))) 43 (and (>= ls lms) 44 (substring=? s maybe-suffix (- ls lms))))) 45 46 (define (terminate-line line) 47 (let ((l (string-length line))) 48 (if (or (zero? l) 49 (eqv? (string-ref line (sub1 l)) #\newline)) 50 line 51 (string-append line "\n")))) 52 53 (define cmd-list '()) 54 55 (define-syntax defcmd 56 (syntax-rules () 57 ((defcmd (name . args) str first . rest) 58 (begin 59 (set! cmd-list (cons (list (symbol->string 'name) str first) cmd-list)) 60 (define (name . args) . rest))))) 61 62 (define vt100-alert "\033[31m") 63 (define vt100-entry-header "\033[34m") 64 (define vt100-reset "\033[0m") 65 66 ;;;;;;;;;;;;;;;;;;;;;;;;;;;; 67 ;; Command-Line Processing 68 69 (define db-filename #f) 70 (define arg-replay #f) 71 72 (let ((arg-list (command-line-arguments))) 73 (when (>= (length arg-list) 2) (set! arg-replay (cadr arg-list))) 74 (when (>= (length arg-list) 1) (set! db-filename (car arg-list)))) 75 76 ;;;;;;;;;;;;; 77 ;; Tracing 78 79 (define trace-port #f) 80 (define display-trace #t) 81 82 (define (trace obj) 83 (when display-trace 84 (write obj) 85 (newline)) 86 (when trace-port 87 (write obj trace-port) 88 (newline trace-port))) 89 90 ;;;;;;;;;;;;;;;;;;;;;;; 91 ;; Persistent Storage 92 93 (define db-name 94 (if db-filename db-filename "iens.sqlite")) 95 96 (define db 97 (open-database db-name)) 98 (write-line (conc "Using database " db-name " with SQLite " library-version)) 99 (exec (sql/transient db "PRAGMA foreign_keys = ON; 100 PRAGMA journal_mode = WAL; 101 PRAGMA synchronous = NORMAL; 102 PRAGMA busy_timeout = 5000;")) 103 (set-busy-handler! db (busy-timeout 10000)) 104 105 (include "common.scm") 106 107 (assert (= 8 (db-version))) 108 109 ;;;;;;;;;;;;;;;;;; 110 ;; Configuration 111 112 (define config-author-name #f) 113 (define config-author-email #f) 114 (define config-author-uri #f) 115 (define config-autogenerate #f) 116 (define config-editor #f) 117 (define config-entry-id-prefix "") 118 (define config-list-tagged-count 0) 119 (define config-verbose #f) 120 121 (define default-editor 122 (let ((term (get-environment-variable "TERM")) 123 (visual (get-environment-variable "VISUAL")) 124 (editor (get-environment-variable "EDITOR")) 125 (fallback "vi")) 126 (cond 127 ((and visual term (not (equal? "dumb" term))) visual) 128 (editor editor) 129 (else fallback)))) 130 131 (define (string->filename data) 132 (cond ((not data) #f) 133 ((starts-with? "~/" data) 134 (string-append (get-environment-variable "HOME") 135 (substring data 1))) 136 (else data))) 137 138 (define (read-config!) 139 (set! display-trace (not (zero? (get-config/default "display-trace" 0)))) 140 (set! config-verbose (not (zero? (get-config/default "verbose" 0)))) 141 (set! rfc-3339 (if (zero? (get-config/default "local-time" 1)) 142 rfc-3339-utc rfc-3339-local)) 143 (set! config-author-name (get-config "author-name")) 144 (set! config-author-email (get-config "author-email")) 145 (set! config-author-uri (get-config "author-uri")) 146 (set! config-autogenerate (not (zero? (get-config/default "autogenerate" 0)))) 147 (set! config-editor (get-config/default "editor" default-editor)) 148 (set! config-entry-id-prefix (get-config/default "entry-id-prefix" "")) 149 (set! config-list-tagged-count (get-config/default "list-tagged-count" 0)) 150 (let ((trace-filename (get-config "trace"))) 151 (when trace-port (close-output-port trace-port)) 152 (set! trace-port 153 (if trace-filename 154 (open-output-file (string->filename trace-filename) #:text #:append) 155 #f))) 156 (history-file (string->filename (get-config "histfile")))) 157 158 (read-config!) 159 160 (defcmd (print-config . args) 161 "[key ...]" "Print configuration" 162 (if (null? args) 163 (query 164 (for-each-row* 165 (lambda (key val) (write-line (conc key ": " val)))) 166 (sql db "SELECT key,val FROM config ORDER BY key;")) 167 (let loop ((todo args)) 168 (unless (null? todo) 169 (write-line (conc (car todo) ": " (get-config (car todo)))) 170 (loop (cdr todo)))))) 171 172 (defcmd (set-config key val) 173 "key value" "Set configuration variable" 174 (trace `(set-config ,key ,val)) 175 (exec (sql db "INSERT OR REPLACE INTO config VALUES (?,?);") key val) 176 (read-config!)) 177 178 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 179 ;; Configurable Query Selectors 180 181 (defcmd (add-selector name text) 182 "\"Name\" \"WHERE …\"" "Creates a pre-defined query selector" 183 (trace `(add-select ,text)) 184 (exec (sql db "INSERT INTO selector(text, name) VALUES (?,?);") text name) 185 (write-line (conc " -> " (last-insert-rowid db)))) 186 187 (define (call-with-selector arg proc) 188 (cond ((string? arg) (proc #f arg arg)) 189 ((number? arg) (let ((selector (get-selector arg))) 190 (if selector 191 (proc arg (car selector) (cadr selector)) 192 (write-line 193 (conc "No selector #" arg " found"))))) 194 (else (write-line (conc "Invalid selection argument " arg))))) 195 196 (define (get-selector id) 197 (query fetch-row (sql db "SELECT name,text FROM selector WHERE id=?;") id)) 198 199 (defcmd (list-selectors) 200 "" "List pre-defined query selectors" 201 (query 202 (for-each-row 203 (lambda (row) 204 (write-line (conc "#" (car row) " " (cadr row) ": \"" (caddr row) "\"")))) 205 (sql db "SELECT id,name,text FROM selector;"))) 206 207 (defcmd (set-selector id name text) 208 "id \"Name\" \"WHERE …\"" "Sets a pre-defined query selector" 209 (trace `(set-selector ,id ,name ,text)) 210 (exec (sql db "INSERT OR REPLACE INTO selector(id,name,text) VALUES (?,?,?);") 211 id name text)) 212 213 ;;;;;;;;;;;;;;;;;;;;; 214 ;; Database Updates 215 216 ;; Feed Management 217 218 (define (set-feed-active id n) 219 (exec (sql db "UPDATE feed SET active=? WHERE id=?;") n id)) 220 221 (defcmd (activate-feed feed-id) 222 "feed-id" "Activate the given feed" 223 (trace `(activate-feed ,feed-id)) 224 (set-feed-active feed-id 1)) 225 226 (defcmd (add-feed filename url selector title) 227 "filename url selector title" "Add a new feed" 228 (trace `(add-feed ,filename ,url ,selector ,title)) 229 (exec (sql db 230 "INSERT INTO feed(filename,url,selector,title) VALUES (?,?,?,?);") 231 filename url selector title) 232 (write-line (conc "Added feed " (last-insert-rowid db)))) 233 234 (defcmd (disable-feed feed-id) 235 "feed-id" "Disable the given feed" 236 (trace `(disable-feed ,feed-id)) 237 (set-feed-active feed-id 0)) 238 239 (defcmd (list-feeds) 240 "" "Display all feeds" 241 (query 242 (map-rows* 243 (lambda (id filename url selector title active-int mtime) 244 (write-line (conc (if (zero? active-int) 245 (conc "(" id ")") 246 (conc "#" id)) 247 " " 248 filename 249 " - " 250 title)) 251 (write-line (conc " " url)) 252 (write-line (conc " " selector)) 253 (unless (null? mtime) 254 (write-line (conc " Updated " (rfc-3339 mtime)))))) 255 (sql db "SELECT id,filename,url,selector,title,active,mtime FROM feed;"))) 256 257 (defcmd (remove-feed feed-id) 258 "feed-id" "Remove the given feed" 259 (trace `(remove-feed ,feed-id)) 260 (exec (sql db "DELETE FROM feed WHERE id=?;") feed-id)) 261 262 (define (touch-feed mtime feed-id) 263 (trace `(touch-feed ,mtime ,feed-id)) 264 (exec (sql db "UPDATE feed SET mtime=? WHERE id=?;") mtime feed-id)) 265 266 ;; Feed Caching 267 268 (define (write-diff sig-diff) 269 (for-each 270 (lambda (hunk) 271 (cond ((eqv? (car hunk) 'add) 272 (write-line (conc " added item #" (cadr hunk) 273 " at " (rfc-3339 (caddr hunk))))) 274 ((eqv? (car hunk) 'del) 275 (write-line (conc " removed item #" (cadr hunk) 276 " at " (rfc-3339 (caddr hunk))))) 277 ((eqv? (car hunk) 'chg) 278 (write-line (conc " updated item #" (cadr hunk) 279 ": " (rfc-3339 (caddr hunk)) 280 " → " (rfc-3339 (cadddr hunk))))) 281 (else (assert #f "Should be unreachable")))) 282 sig-diff)) 283 284 (define feed-cache 285 (query (map-rows* (lambda (id selector) 286 (cons id (build-signature selector)))) 287 (sql db "SELECT id,selector FROM feed WHERE active=1;"))) 288 (define dirty-feeds '()) 289 290 (define (check-feed* id) 291 (let ((new (query fetch-value 292 (sql db "SELECT selector FROM feed WHERE id=?;") 293 id)) 294 (old (alist-ref id feed-cache = '()))) 295 (cond ((and (not new) (null? old)) 296 (write-line (conc "Feed #" id " does not exist"))) 297 ((not new) 298 (write-line (conc "Feed #" id " does not exist anymore"))) 299 ((null? old) 300 (write-line (conc "Feed #" id " is not cached"))) 301 (else 302 (let ((sig-diff (diff-signature old (build-signature new)))) 303 (if (null? sig-diff) 304 (write-line (conc "Feed #" id " has not changed")) 305 (write-line (conc "Feed #" id " was modified:"))) 306 (write-diff sig-diff)))))) 307 308 (defcmd (check-feed . args) 309 "[feed-id ...]" "Check the cache for the given feeds, or all active feeds" 310 (for-each check-feed* 311 (if (null? args) 312 (query fetch-column (sql db "SELECT id FROM feed WHERE active=1;")) 313 args))) 314 315 (define (update-feed-cache* mtime id) 316 (let ((data (query fetch-row 317 (sql db "SELECT mtime,selector,filename,title,url 318 FROM feed WHERE id=?;") 319 id)) 320 (old-sig (alist-ref id feed-cache = '()))) 321 (if (null? data) 322 (write-line (conc "Feed #" id " does not exist")) 323 (let ((new-sig (build-signature (cadr data)))) 324 (unless (equal? old-sig new-sig) 325 (when (or (null? (car data)) 326 (> mtime (car data))) 327 (touch-feed mtime id) 328 (set! (car data) mtime)) 329 (when config-verbose 330 (write-line (if config-autogenerate 331 (conc "Autogenerating feed " id) 332 (conc "Marking feed " id " as dirty:"))) 333 (write-diff (diff-signature old-sig new-sig))) 334 (if config-autogenerate 335 (with-output-to-file (caddr data) ;filename 336 (cut write-feed 337 (car data) ;mtime 338 (list-ref data 3) ;title 339 (list-ref data 4) ;url 340 (query fetch-rows 341 (sql db (string-append "SELECT id,url,type,description, 342 notes,ptime,ctime,mtime 343 FROM entry " (cadr data) ";"))))) 344 (unless (any (cut = id <>) dirty-feeds) 345 (set! dirty-feeds (cons id dirty-feeds)))) 346 (set! feed-cache 347 (alist-update! id new-sig feed-cache =))))))) 348 349 (define (update-feed-cache mtime . id-list) 350 (for-each 351 (cut update-feed-cache* mtime <>) 352 (if (null? id-list) 353 (query fetch-column (sql db "SELECT id FROM feed WHERE active=1;")) 354 id-list))) 355 356 ;; Tag Management 357 358 (define (set-tag-auto name auto) 359 (exec (sql db "UPDATE tag SET auto=? WHERE name=?;") auto name)) 360 361 (defcmd (add-auto-tag name . rest) 362 "tag-name [tag-name ...]" "Set tags as automatic" 363 (trace `(add-auto-tag ,name)) 364 (set-tag-auto name 1) 365 (unless (null? rest) 366 (apply add-auto-tag rest))) 367 368 (defcmd (add-tag name . rest) 369 "tag-name [tag-name ...]" "Create a new tag" 370 (trace `(add-tag ,name)) 371 (exec (sql db "INSERT INTO tag(name) VALUES (?);") name) 372 (unless (null? rest) 373 (apply add-tag rest))) 374 375 (defcmd (auto-tags . tag-list) 376 "[tag-name ...]" "Set the list of automatic tags" 377 (trace `(auto-tags . ,tag-list)) 378 (with-transaction db 379 (lambda () 380 (exec (sql db "UPDATE tag SET auto=0;")) 381 (let loop ((todo tag-list)) 382 (unless (null? todo) 383 (set-tag-auto (car todo) 1) 384 (loop (cdr todo))))))) 385 386 (define (n-split l n) 387 (let loop ((todo-l l) (todo-n n) (acc '())) 388 (if (or (zero? todo-n) (null? todo-l)) 389 (reverse acc) 390 (let ((chunk-size (ceiling (/ (length todo-l) todo-n)))) 391 (loop (drop todo-l chunk-size) 392 (sub1 todo-n) 393 (cons (take todo-l chunk-size) acc)))))) 394 395 (define (expand-cols cols) 396 (let loop ((todo cols) (acc '())) 397 (if (> (length todo) 1) 398 (loop 399 (cons (append (cadr todo) 400 (make-list (- (length (car todo)) (length (cadr todo))) 401 "")) 402 (cddr todo)) 403 (let ((width (apply max (map string-length (car todo))))) 404 (cons 405 (append 406 (map (lambda (s t) 407 (string-append 408 s 409 (make-string (- width -2 (string-length s)) 410 #\space))) 411 (car todo) 412 (cadr todo)) 413 (drop (car todo) (length (cadr todo)))) 414 acc))) 415 (reverse (append todo acc))))) 416 417 (defcmd (list-tags #!optional (cols 1) (threshold 0)) 418 "[n-columns [min-count]]" 419 "List available tag, automatic tags are marked with *" 420 (apply for-each 421 (lambda row 422 (write-line (apply string-append row))) 423 (expand-cols 424 (n-split 425 (query 426 (map-rows* 427 (lambda (name auto count) 428 (conc name (if (zero? auto) " (" "* (") count ")"))) 429 (sql db "SELECT name,auto,COUNT(tagrel.url_id) AS cnt 430 FROM tag OUTER LEFT JOIN tagrel ON id=tagrel.tag_id 431 GROUP BY id HAVING cnt >= ? ORDER BY name;") 432 threshold) 433 cols)))) 434 435 (defcmd (remove-auto-tag name . rest) 436 "[tag-name ...]" "Set tags as not automatic" 437 (trace `(remove-auto-tag ,name)) 438 (set-tag-auto name 0) 439 (unless (null? rest) 440 (apply remove-auto-tag rest))) 441 442 (defcmd (remove-tag name . rest) 443 "tag-name [tag-name ...]" "Remove tags" 444 (trace `(remove-tag ,name)) 445 (exec (sql db "DELETE FROM tag WHERE name=?;") name) 446 (unless (null? rest) 447 (apply remove-tag rest))) 448 449 (defcmd (rename-tag old-name new-name) 450 "old-tag-name new-tag-name" "Rename a tag, preserving associations" 451 (trace `(rename-tag ,old-name ,new-name)) 452 (exec (sql db "UPDATE tag SET name=? WHERE name=?;") new-name old-name)) 453 454 ;; Entry Protection 455 456 (define (is-protected? entry-id) 457 (not (zero? 458 (query fetch-value 459 (sql db "SELECT protected FROM entry WHERE id=?;") 460 entry-id)))) 461 462 (define protection-overrides '()) 463 464 (define (is-overridden? entry-id) 465 (any (cut = entry-id <>) protection-overrides)) 466 467 (define (update-allowed? entry-id) 468 (or (not (is-protected? entry-id)) (is-overridden? entry-id))) 469 470 (define-syntax unless-protected 471 (syntax-rules () 472 ((unless-protected entry-id . form) 473 (if (update-allowed? entry-id) 474 (begin . form) 475 (write-line (conc "Warning: entry " entry-id " is protected")))))) 476 477 (define (unoverride! entry-id) 478 (trace `(unoverride! ,entry-id)) 479 (set! protection-overrides (delete! entry-id protection-overrides =))) 480 481 (define (protect* ptime entry-id) 482 (trace `(protect ,ptime ,entry-id)) 483 (unless-protected entry-id 484 (exec (sql db "UPDATE entry SET protected=1,ptime=? WHERE id=?;") 485 ptime entry-id) 486 (update-feed-cache ptime))) 487 488 (defcmd (protect . args) 489 "[[timestamp] entry-id]" "Protect entries from modification" 490 (cond ((null? args) 491 (protect* (current-seconds) cur-entry)) 492 ((null? (cdr args)) 493 (protect* (current-seconds) (car args))) 494 (else 495 (protect* (car args) (cadr args))))) 496 497 (define (override! entry-id) 498 (trace `(override! ,entry-id)) 499 (unless (update-allowed? entry-id) 500 (set! protection-overrides (cons entry-id protection-overrides)))) 501 502 (define (unprotect* mtime entry-id) 503 (trace `(unprotect ,mtime ,entry-id)) 504 (exec (sql db "UPDATE entry SET protected=0,ptime=NULL,mtime=? WHERE id=?;") 505 mtime entry-id) 506 (update-feed-cache mtime)) 507 508 (defcmd (unprotect . args) 509 "[[timestamp] entry-id]" "Unprotect entries from modification" 510 (cond ((null? args) 511 (unprotect* (current-seconds) cur-entry)) 512 ((null? (cdr args)) 513 (unprotect* (current-seconds) (car args))) 514 (else 515 (unprotect* (car args) (cadr args))))) 516 517 (define (without-protection* entry-id proc) 518 (if (or (procedure? proc) (list? proc)) 519 (let ((prev-cur-entry-id cur-entry)) 520 (set! cur-entry entry-id) 521 (if (is-protected? entry-id) 522 (begin 523 (override! entry-id) 524 (if (procedure? proc) (proc) (eval proc)) 525 (unoverride! entry-id)) 526 (if (procedure? proc) (proc) (eval proc))) 527 (set! cur-entry prev-cur-entry-id)) 528 (write-line (conc "Invalid procedure " proc)))) 529 530 (defcmd (without-protection! first . args) 531 "[entry-id] '(...)" "Perform updates bypassing protection" 532 (cond ((null? args) 533 (without-protection* cur-entry first)) 534 ((and (null? (cdr args)) (integer? first)) 535 (without-protection* first (car args))) 536 (else (assert #f "Invalid arguments " (cons first args))))) 537 538 ;; Entry Management 539 540 (define cur-entry 541 (query fetch-value 542 (sql/transient db "SELECT id FROM entry ORDER BY id DESC LIMIT 1;"))) 543 544 (define (time-id-strings args) 545 (cond ((or (null? args) (string? (car args))) 546 (list (current-seconds) cur-entry args)) 547 ((not (integer? (car args))) 548 (assert #f "Unknown type parameter for " (car args))) 549 ((or (null? (cdr args)) (string? (cadr args))) 550 (list (current-seconds) (car args) (cdr args))) 551 ((integer? (cadr args)) 552 (list (car args) (cadr args) (cddr args))) 553 (else (assert #f "Unknown type parameter for " (cadr args))))) 554 555 (define (add-entry* ctime spec notes) 556 (assert (or (string? spec) (and (list? spec) (= 3 (length spec)))) 557 "Bad entry spec " spec) 558 (trace `(add-entry ,ctime ,spec ,notes)) 559 (let ((new-id 560 (with-transaction db 561 (lambda () 562 (let ((source (if (list? spec) (car spec) '())) 563 (title (if (list? spec) (cadr spec) '())) 564 (url (if (list? spec) (caddr spec) spec)) 565 (s-url (cond ((not (list? spec)) #f) 566 ((null? (cdddr spec)) 567 (comment-link (car spec) (cadr spec))) 568 (else (cadddr spec))))) 569 (exec (sql db "INSERT INTO entry(url,title,source,source_url, 570 notes,ctime,mtime) 571 VALUES (?,?,?,?,?,?,?);") 572 url 573 title 574 source 575 (if s-url s-url '()) 576 notes 577 ctime 578 ctime)) 579 (let ((new-id (last-insert-rowid db))) 580 (exec (sql db "INSERT INTO tagrel SELECT ?,id FROM tag WHERE auto=1;") 581 new-id) 582 new-id))))) 583 (set! cur-entry new-id) 584 (write-line (conc "Added " new-id))) 585 (update-feed-cache ctime)) 586 587 (defcmd (add-entry first second . rest) 588 "[timestamp] URL note-line [note-line ...]" "Create a new entry" 589 (if (or (null? rest) (string? first) (list? first)) 590 (add-entry* (current-seconds) 591 first 592 (apply string-append (map terminate-line (cons second rest)))) 593 (add-entry* first 594 second 595 (apply string-append (map terminate-line rest))))) 596 597 (define (add-notes* mtime entry-id lines) 598 (unless (null? lines) 599 (trace `(add-notes ,mtime ,entry-id . ,lines)) 600 (with-transaction db 601 (lambda () 602 (let ((prev-notes (query fetch-value 603 (sql db "SELECT notes FROM entry WHERE id=?;") 604 entry-id))) 605 (unless-protected entry-id 606 (exec (sql db "UPDATE entry SET notes=?,mtime=? WHERE id=?;") 607 (apply string-append prev-notes 608 (map terminate-line lines)) 609 mtime 610 entry-id)))))) 611 (update-feed-cache mtime)) 612 613 (defcmd (add-notes . args) 614 "[[timestamp] entry-id] note-line [note-line ...]" 615 "Append new lines of notes" 616 (apply add-notes* (time-id-strings args))) 617 618 (define (print-entry-row id url type descr notes title source source-url 619 protected ptime ctime mtime tags) 620 (write-line (conc vt100-entry-header 621 "#" id (if (zero? protected) "" "*") " - " url 622 vt100-reset)) 623 (unless (null? ctime) (write-line (conc "Created: " (rfc-3339 ctime)))) 624 (unless (null? ptime) (write-line (conc "Protected: " (rfc-3339 ptime)))) 625 (unless (null? mtime) (write-line (conc "Modified: " (rfc-3339 mtime)))) 626 (unless (null? title) (write-line (conc "Title: " title))) 627 (if (null? source) 628 (unless (null? source-url) 629 (write-line (conc "Orphan source URL: " source-url))) 630 (write-line (conc "from " source 631 (if (null? source-url) "" (conc " " source-url))))) 632 (unless (null? descr) 633 (if (null? type) 634 (write-line "Description:") 635 (write-line (conc "Description (" type "):"))) 636 (write-string descr)) 637 (unless (null? notes) 638 (write-line (conc "Notes:")) 639 (write-string notes)) 640 (if (null? tags) 641 (write-line "No tags.") 642 (write-line (string-append "Tags: " tags)))) 643 644 (define (print-listed-entry-row id url notes protected) 645 (write-line (conc vt100-entry-header 646 "#" id (if (zero? protected) "" "*") " - " url 647 vt100-reset)) 648 (write-string notes)) 649 650 (define (count-selection* id name text) 651 (write-line (string-append (if id (conc "#" id ": ") "") 652 "\"" name "\"")) 653 (write-line (conc " -> " (query fetch-value 654 ((if id sql sql/transient) 655 db 656 (string-append 657 "SELECT COUNT(id) FROM entry " 658 text ";")))))) 659 660 (defcmd (count-selection . args) 661 "\"WHERE ...\"|selector-id ..." "Count results of a custom queries" 662 (if (null? args) 663 (query (for-each-row* count-selection*) 664 (sql db "SELECT id,name,text FROM selector;")) 665 (let loop ((todo args)) 666 (unless (null? todo) 667 (call-with-selector (car todo) count-selection*) 668 (loop (cdr todo)))))) 669 670 (defcmd (list-selection arg) 671 "\"WHERE ...\"|selector-id" "Display a custom query as an entry list" 672 (call-with-selector arg 673 (lambda (id title selector) 674 (query (for-each-row* print-listed-entry-row) 675 ((if id sql sql/transient) db 676 (string-append "SELECT id,url,notes,protected FROM entry " 677 selector ";")))))) 678 679 (defcmd (list-tagged tag-name #!optional (count config-list-tagged-count)) 680 "tag-name [limit]" "Display entries with the given tag" 681 (query (for-each-row* print-listed-entry-row) 682 (sql db (cond ((positive? count) 683 "SELECT * FROM 684 (SELECT id,url,notes,protected FROM entry 685 WHERE id IN (SELECT url_id FROM tagrel 686 WHERE tag_id IN (SELECT id FROM tag 687 WHERE name=?)) 688 ORDER BY id DESC LIMIT ?) 689 ORDER BY id ASC;") 690 ((negative? count) 691 "SELECT id,url,notes,protected FROM entry 692 WHERE id IN (SELECT url_id FROM tagrel 693 WHERE tag_id IN (SELECT id FROM tag 694 WHERE name=?)) 695 ORDER BY id ASC LIMIT ?;") 696 (else ; (zero? count) 697 "SELECT id,url,notes,protected FROM entry 698 WHERE id IN (SELECT url_id FROM tagrel 699 WHERE tag_id IN (SELECT id FROM tag 700 WHERE name=?)) 701 OR id=? 702 ORDER BY id ASC;"))) 703 tag-name 704 (abs count))) 705 706 (defcmd (list-untagged) 707 "" "Display entries without any tag" 708 (query (for-each-row* print-listed-entry-row) 709 (sql db "SELECT id,url,notes,protected FROM entry 710 WHERE id NOT IN (SELECT url_id FROM tagrel);"))) 711 712 (define (print-entry* entry-id) 713 (query (for-each-row* print-entry-row) 714 (sql db "SELECT entry.id, url, type, description, notes, 715 title, source, source_url, protected, 716 ptime, ctime, mtime, group_concat(tag.name, ' ') 717 FROM entry 718 LEFT OUTER JOIN tagrel ON entry.id=tagrel.url_id 719 LEFT OUTER JOIN tag ON tag.id=tagrel.tag_id 720 WHERE entry.id=? GROUP BY entry.id;") 721 entry-id)) 722 723 (defcmd (print-entry . args) 724 "[entry-id]" "Display an entry" 725 (if (null? args) 726 (print-entry* cur-entry) 727 (let loop ((todo args)) 728 (unless (null? todo) 729 (print-entry* (car todo)) 730 (loop (cdr todo)))))) 731 732 (defcmd (print-selection arg) 733 "\"WHERE ...\"|selector-id" "Display entries from a custom query" 734 (call-with-selector arg 735 (lambda (id title selector) 736 (query 737 (for-each-row* print-entry-row) 738 ((if id sql sql/transient) db 739 (string-append 740 "SELECT entry.id, url, type, description, notes, 741 title, source, source_url, protected, 742 ptime, ctime, mtime, group_concat(tag.name, ' ') 743 FROM entry 744 LEFT OUTER JOIN tagrel ON entry.id=tagrel.url_id 745 LEFT OUTER JOIN tag ON tag.id=tagrel.tag_id " 746 selector 747 " GROUP BY entry.id;")))))) 748 749 (defcmd (random-tagged tag-name) 750 "tag" "Select a random entry with the given tag" 751 (let ((entry-id (query fetch-value 752 (sql db "SELECT url_id FROM tagrel WHERE tag_id IN 753 (SELECT id FROM tag WHERE name=?) 754 ORDER BY RANDOM() LIMIT 1;") 755 tag-name))) 756 (if entry-id 757 (begin 758 (set! cur-entry entry-id) 759 (print-entry)) 760 (write-line "No such entry found")))) 761 762 (defcmd (random-untagged) 763 "" "Select a random entry without tag" 764 (let ((entry-id (query fetch-value 765 (sql db "SELECT id FROM entry WHERE id NOT IN 766 (SELECT url_id FROM tagrel) 767 ORDER BY RANDOM() LIMIT 1;")))) 768 (if entry-id 769 (begin 770 (set! cur-entry entry-id) 771 (print-entry)) 772 (write-line "No such entry found")))) 773 774 (define (guess-type str) 775 (cond ((null? str) '()) 776 ((starts-with? "<" str) "html") 777 ((or (starts-with? " - " str) 778 (starts-with? " + " str)) "markdown-li") 779 (else "text"))) 780 781 (define (set-descr* mtime entry-id type text) 782 (trace `(set-descr ,mtime ,entry-id ,type ,text)) 783 (unless-protected entry-id 784 (exec (sql db "UPDATE entry SET type=?,description=?,mtime=? WHERE id=?;") 785 type text mtime entry-id) 786 (update-feed-cache mtime))) 787 788 (defcmd (set-descr first . args) 789 "[[[mtime] entry-id] type] description" "Sets an entry description" 790 (case (length args) 791 ((0) (set-descr* (current-seconds) cur-entry (guess-type first) first)) 792 ((1) (set-descr* (current-seconds) cur-entry first (car args))) 793 ((2) (set-descr* (current-seconds) first (car args) (cadr args))) 794 ((3) (set-descr* first (car args) (cadr args) (caddr args))) 795 (else (assert #f "Too many arguments to set-descr " (cons first args))))) 796 797 (define (set-source* mtime entry-id source source-url) 798 (trace `(set-source ,mtime ,entry-id ,source ,source-url)) 799 (unless-protected entry-id 800 (exec (sql db "UPDATE entry 801 SET source=?, source_url=COALESCE(?,source_url), mtime=? 802 WHERE id=?;") 803 source source-url mtime entry-id))) 804 805 (defcmd (set-source first . args) 806 "[[mtime] entry-id] source [source-URL]" "Sets entry source" 807 (case (length args) 808 ((0) (set-source* (current-seconds) cur-entry first '())) 809 ((1) (cond 810 ((string? (car args)) 811 (set-source* (current-seconds) cur-entry first (car args))) 812 ((number? (car args)) 813 (set-source* (current-seconds) first (car args) '())) 814 (else (assert #f "Unsupported arg types in " (cons first args))))) 815 ((2) (cond 816 ((string? (cadr args)) 817 (set-source* (current-seconds) first (car args) (cadr args))) 818 ((number? (cadr args)) 819 (set-source* first (car args) (cadr args) '())) 820 (else (assert #f "Unsupported arg types in " (cons first args))))) 821 ((3) (set-descr* first (car args) (cadr args) (caddr args))) 822 (else (assert #f "Too many arguments to set-source " (cons first args))))) 823 824 (define (set-title* mtime entry-id title) 825 (trace `(set-title ,mtime ,entry-id ,title)) 826 (unless-protected entry-id 827 (exec (sql db "UPDATE entry SET title=?, mtime=? WHERE id=?;") 828 title mtime entry-id))) 829 830 (defcmd (set-title first . args) 831 "[[mtime] entry-id] title" "Sets entry title" 832 (case (length args) 833 ((0) (set-title* (current-seconds) cur-entry first)) 834 ((1) (set-title* (current-seconds) first (car args))) 835 ((2) (set-title* first (car args) (cadr args))) 836 (else (assert #f "Too many arguments to set-title " (cons first args))))) 837 838 (defcmd (set-entry arg) 839 "entry-id|url" "Set current entry" 840 (cond ((integer? arg) 841 (set! cur-entry arg) 842 (when config-verbose (print-entry))) 843 ((string? arg) 844 (let ((id (query fetch-value 845 (sql db "SELECT id FROM entry WHERE url=?;") 846 arg))) 847 (if id 848 (begin 849 (set! cur-entry id) 850 (when config-verbose (print-entry))) 851 (write-line (conc "No entry found for \"" arg "\""))))) 852 (else (assert #f "Unsupported argument type for " arg)))) 853 854 (define (touch* mtime entry-id) 855 (trace `(touch ,mtime ,entry-id)) 856 (unless-protected entry-id 857 (exec (sql db "UPDATE entry SET mtime=? WHERE id=?;") mtime entry-id) 858 (update-feed-cache mtime))) 859 860 (define (touch . args) 861 (cond ((null? args) 862 (touch* (current-seconds) cur-entry)) 863 ((not (integer? (car args))) 864 (assert #f "Bad type for " (car args))) 865 ((null? (cdr args)) 866 (touch* (current-seconds) (car args))) 867 ((not (integer? (cadr args))) 868 (assert #f "Bad type for " (car args))) 869 (else 870 (touch* (car args) (cadr args))))) 871 872 (define (without-mtime* entry-id proc) 873 (if (or (procedure? proc) (list? proc)) 874 (let ((prev-entry cur-entry) 875 (prev-mtime (query fetch-value 876 (sql db "SELECT mtime FROM entry WHERE id=?;") 877 entry-id))) 878 (set! cur-entry entry-id) 879 (if (procedure? proc) (proc) (eval proc)) 880 (touch* prev-mtime entry-id) 881 (set! cur-entry prev-entry)) 882 (write-line (conc "Invalid procedure " proc)))) 883 884 (defcmd (without-mtime! first . args) 885 "[entry-id] '(...)" "Perform updates and restore entry mtime" 886 (cond ((null? args) 887 (without-mtime* cur-entry first)) 888 ((and (null? (cdr args)) (integer? first)) 889 (without-mtime* first (car args))) 890 (else (assert #f "Invalid arguments " (cons first args))))) 891 892 ;; Entry Tagging 893 894 (define (print-tags* entry-id) 895 (write-line (apply conc (append (list "Tags for " entry-id ":") 896 (query (map-rows (lambda (x) (string-append " " (car x)))) 897 (sql db "SELECT tag.name FROM tagrel 898 OUTER LEFT JOIN tag ON tagrel.tag_id=tag.id 899 WHERE url_id=? ORDER BY tag.name;") 900 entry-id))))) 901 902 (defcmd (print-tags . args) 903 "[entry-id ...]" "Print tags associated with an entry" 904 (if (null? args) 905 (print-tags* cur-entry) 906 (let loop ((todo args)) 907 (unless (null? todo) 908 (print-tags* (car todo)) 909 (loop (cdr todo)))))) 910 911 912 (define (resolve-tag-id tag-name) 913 (let ((result (query fetch-value 914 (sql db "SELECT id from tag WHERE name=?;") 915 tag-name))) 916 (unless result 917 (write-line (conc "Unknown tag " tag-name))) 918 result)) 919 920 (define (exec-on-tags stmt mtime entry-id tag-list) 921 (with-transaction db 922 (lambda () 923 (unless-protected entry-id 924 (let ((tag-id-list (map resolve-tag-id tag-list))) 925 (when (every identity tag-id-list) 926 (let loop ((todo tag-id-list)) 927 (if (null? todo) 928 (exec (sql db "UPDATE entry SET mtime=? WHERE id=?;") 929 mtime entry-id) 930 (begin 931 (exec stmt entry-id (car todo)) 932 (loop (cdr todo)))))))))) 933 (print-tags entry-id) 934 (update-feed-cache mtime)) 935 936 (define (retag* mtime entry-id tag-list) 937 (trace `(retag ,mtime ,entry-id . ,tag-list)) 938 (unless-protected entry-id 939 (exec (sql db "DELETE FROM tagrel WHERE url_id=?;") entry-id) 940 (exec-on-tags (sql db "INSERT OR IGNORE INTO tagrel VALUES (?,?);") 941 mtime entry-id tag-list))) 942 943 (defcmd (retag . args) 944 "[[timestamp] entry-id] tag-name [tag-name ...]" 945 "Overwrite tag list for an entry" 946 (apply retag* (time-id-strings args))) 947 948 (define (tag* mtime entry-id tag-list) 949 (unless (null? tag-list) 950 (trace `(tag ,mtime ,entry-id . ,tag-list)) 951 (exec-on-tags (sql db "INSERT OR IGNORE INTO tagrel VALUES (?,?);") 952 mtime entry-id tag-list))) 953 954 (defcmd (tag . args) 955 "[[timestamp] entry-id] tag-name [tag-name ...]" 956 "Associate tags to an entry" 957 (apply tag* (time-id-strings args))) 958 959 (define (untag* mtime entry-id tag-list) 960 (unless (null? tag-list) 961 (trace `(untag ,mtime ,entry-id . ,tag-list)) 962 (exec-on-tags (sql db "DELETE FROM tagrel WHERE url_id=? AND tag_id=?;") 963 mtime entry-id tag-list))) 964 965 (defcmd (untag . args) 966 "[[timestamp] entry-id] tag-name [tag-name ...]" 967 "Disssociates tags from an entry" 968 (apply untag* (time-id-strings args))) 969 970 ;;;;;;;;;;;;;;;;;;;; 971 ;; Editor Spawning 972 973 (define (edit-descr* entry-id) 974 (let ((file-name (create-temporary-file 975 (string-append "." 976 (get-config/default "description-ext" "txt")))) 977 (fields 978 (query fetch-row 979 (sql db "SELECT description,notes,url,source,source_url 980 FROM entry WHERE id=?;") 981 entry-id))) 982 (unless (null? fields) 983 (call-with-output-file file-name 984 (lambda (port) 985 (if (or (null? (car fields)) (string=? (car fields) "")) 986 (begin 987 (write-string (conc " + [](" (caddr fields) ")\n") #f port) 988 (unless (null? (cadddr fields)) 989 (write-string 990 (conc "(via " 991 (if (null? (list-ref fields 4)) 992 (cadddr fields) 993 (conc "[" (cadddr fields) "](" (list-ref fields 4) ")")) 994 " sur #gcufeed)\n") 995 #f port))) 996 (write-string (car fields) #f port)) 997 (unless (null? (cadr fields)) 998 (write-string "-+-+-\n" #f port) 999 (write-string (cadr fields) #f port))))) 1000 (when config-editor 1001 (process-wait 1002 (process-run (string-append config-editor " " (qs file-name))))) 1003 (let ((result (call-with-input-file file-name 1004 (lambda (port) 1005 (let* ((text (read-string #f port)) 1006 (end (substring-index-ci "-+-+-\n" text))) 1007 (if end 1008 (substring text 0 end) 1009 text)))))) 1010 (delete-file file-name) 1011 (if (or (zero? (string-length result)) 1012 (equal? (if (or (null? fields) (null? (car fields))) 1013 "" (car fields)) 1014 result)) 1015 #f 1016 result)))) 1017 1018 1019 (defcmd (edit-descr . args) 1020 "[[mtime] entry-id]" "Describe using an external editor" 1021 (let ((new-value (case (length args) 1022 ((0) (edit-descr* cur-entry)) 1023 ((1) (edit-descr* (car args))) 1024 ((2) (edit-descr* (cadr args))) 1025 (else 1026 (assert #f "Too many arguments to edit-descr " args))))) 1027 (when new-value 1028 (case (length args) 1029 ((0) (set-descr* (current-seconds) 1030 cur-entry 1031 (guess-type new-value) 1032 new-value)) 1033 ((1) (set-descr* (current-seconds) 1034 (car args) 1035 (guess-type new-value) 1036 new-value)) 1037 ((2) (set-descr* (car args) 1038 (cadr args) 1039 (guess-type new-value) 1040 new-value)) 1041 (else (assert #f "Too many arguments to edit-descr " args)))))) 1042 1043 (define (auto-cols widths avail) 1044 (letrec ((len (vector-length widths)) 1045 (w-slice (lambda (start len acc) 1046 (if (< len 1) 1047 acc 1048 (w-slice (+ start 1) (- len 1) 1049 (max acc (vector-ref widths start)))))) 1050 (w-total (lambda (start stride acc) 1051 (if (< (+ start stride) len) 1052 (w-total (+ start stride) 1053 stride 1054 (cons (+ (car acc) 1 (w-slice start stride 0)) 1055 acc)) 1056 (cons (+ (car acc) (w-slice start (- len start) 0)) 1057 acc)))) 1058 (h-cols (lambda (ncols) (quotient (+ len ncols -1) ncols))) 1059 (w-cols (lambda (ncols) (w-total 0 (h-cols ncols) (list 0))))) 1060 (let loop ((ncols len) (best #f)) 1061 (if (zero? ncols) best 1062 (let ((w (w-cols ncols)) (h (h-cols ncols))) 1063 (loop (- ncols 1) 1064 (if (and (< (car w) avail) 1065 (or (not best) (<= h (car best)))) 1066 (list h (list->vector (reverse (cdr w)))) 1067 best))))))) 1068 1069 (define (select-tags** entry-id tags) 1070 (let* ((ntags (vector-length tags)) 1071 (state (list->vector (map cadddr (vector->list tags)))) 1072 (cols (auto-cols (list->vector 1073 (map (lambda (x) 1074 (+ (string-length (cadr x)) 1075 (string-length (caddr x)))) 1076 (vector->list tags))) (COLS))) 1077 (stride (car cols)) 1078 (x-cols (cadr cols)) 1079 (show-tag (lambda (index sel) 1080 (unless (zero? (vector-ref state index)) 1081 ; (attron (COLOR_PAIR 1))) 1082 (attron A_REVERSE)) 1083 (when (= index sel) 1084 ; (attron A_REVERSE)) 1085 (attron A_UNDERLINE)) 1086 (mvprintw 1087 (remainder index stride) 1088 (vector-ref x-cols (quotient index stride)) 1089 "~A~A" 1090 (cadr (vector-ref tags index)) 1091 (caddr (vector-ref tags index))) 1092 (when (= index sel) 1093 ; (attroff A_REVERSE)) 1094 (attroff A_UNDERLINE)) 1095 (unless (zero? (vector-ref state index)) 1096 ; (attroff (COLOR_PAIR 1))))) 1097 (attroff A_REVERSE)))) 1098 (update-tags (lambda (old new) (show-tag old new) (show-tag new new)))) 1099 (keypad (stdscr) #t) 1100 (noecho) 1101 (curs_set 0) 1102 ; (start_color) 1103 ; (init_pair 1 COLOR_BLUE COLOR_BLACK) 1104 (let init ((index 0)) 1105 (when (< index ntags) 1106 (show-tag index 0) 1107 (init (+ index 1)))) 1108 (let loop ((sel 0)) 1109 (let ((c (char->integer (getch)))) 1110 (cond 1111 ((= c KEY_UP) 1112 (let ((next-sel (modulo (- sel 1) ntags))) 1113 (update-tags sel next-sel) 1114 (loop next-sel))) 1115 ((= c KEY_DOWN) 1116 (let ((next-sel (modulo (+ sel 1) ntags))) 1117 (update-tags sel next-sel) 1118 (loop next-sel))) 1119 ((= c KEY_LEFT) 1120 (let ((next-sel (if (>= sel stride) 1121 (- sel stride) 1122 (min (+ sel (- ntags (modulo ntags stride))) 1123 (- ntags 1))))) 1124 (update-tags sel next-sel) 1125 (loop next-sel))) 1126 ((= c KEY_RIGHT) 1127 (let ((next-sel (cond ((< (+ sel stride) ntags) 1128 (+ sel stride)) 1129 ((< sel (- ntags (modulo ntags stride))) 1130 (- ntags 1)) 1131 (else (modulo sel stride))))) 1132 (update-tags sel next-sel) 1133 (loop next-sel))) 1134 ((= c 32) 1135 (vector-set! state sel (- 1 (vector-ref state sel))) 1136 (show-tag sel sel) 1137 (loop sel)) 1138 ((= c 10) 1139 (let result ((index 0) (add '()) (del '())) 1140 (cond 1141 ((>= index ntags) 1142 (list add del)) 1143 ((= (cadddr (vector-ref tags index)) (vector-ref state index)) 1144 (result (+ index 1) add del)) 1145 ((zero? (vector-ref state index)) 1146 (result (+ index 1) add 1147 (cons (cadr (vector-ref tags index)) del))) 1148 (else 1149 (result (+ index 1) 1150 (cons (cadr (vector-ref tags index)) add) 1151 del))))) 1152 ((= c 27) '(()())) 1153 ((or (<= 65 c 90) (<= 97 c 122)) 1154 (let search ((prev-sel sel) 1155 (prev-ch (char->integer (string-ref 1156 (cadr (vector-ref tags sel)) 0)))) 1157 (let* ((next-sel (modulo (+ prev-sel 1) ntags)) 1158 (next-ch (char->integer (string-ref 1159 (cadr (vector-ref tags next-sel)) 0)))) 1160 (cond 1161 ((= next-sel sel) 1162 (loop sel)) 1163 ((or (= next-ch c) (< prev-ch c next-ch)) 1164 (update-tags sel next-sel) 1165 (loop next-sel)) 1166 (else (search next-sel next-ch)))))) 1167 (else (mvprintw (+ 1 stride) 0 "~S ~S" KEY_DOWN c) (loop sel))))))) 1168 1169 (define (select-tags* entry-id) 1170 (if (update-allowed? entry-id) 1171 (let ((tags (list->vector (query 1172 (map-rows* (lambda (id name count active) 1173 (list id name (conc " (" count ")") 1174 active))) 1175 (sql db 1176 "SELECT id,name,COUNT(url_id),COALESCE(MAX(url_id==?),0) 1177 FROM tag LEFT OUTER JOIN tagrel ON tag_id=tag.id 1178 GROUP BY tag.name;") 1179 entry-id)))) 1180 (dynamic-wind initscr (lambda () (select-tags** entry-id tags)) endwin)) 1181 '(()()))) 1182 1183 (defcmd (select-tags . args) 1184 "[[mtime] entry-id]" "Interactively select tags using dialog(1)" 1185 (let* ((entry-id (case (length args) 1186 ((0) cur-entry) 1187 ((1) (car args)) 1188 ((2) (cadr args)) 1189 (else 1190 (assert #f "Too many arguments to select-tags " args)))) 1191 (mtime (if (= 2 (length args)) (car args) (current-seconds))) 1192 (changes (select-tags* entry-id)) 1193 (added (car changes)) 1194 (removed (cadr changes))) 1195 (unless-protected entry-id 1196 (untag* (- mtime 1) entry-id removed) 1197 (tag* mtime entry-id added)))) 1198 1199 ;;;;;;;;;;;;;;;;;;;;; 1200 ;; Gruik Management 1201 1202 (define (pull-gruiks* mtime mark) 1203 (let ((last-id (query fetch-value (sql db "SELECT MAX(id) FROM entry;")))) 1204 (exec 1205 (sql db "INSERT OR IGNORE 1206 INTO entry(url,type,description,notes,ctime,mtime) 1207 SELECT url, 1208 CASE WHEN description IS NULL THEN NULL 1209 WHEN substr(description,1,1)='<' THEN 'html' 1210 WHEN substr(description,1,3)=' - ' 1211 OR substr(description,1,3)=' + ' THEN 'markdown-li' 1212 ELSE 'text' END, 1213 trim(description,char(10))||char(10), 1214 trim(notes,char(10))||char(10), 1215 stime,? 1216 FROM gruik 1217 WHERE mark=? AND url NOT IN (SELECT url FROM entry);") 1218 mtime 1219 mark) 1220 (exec 1221 (sql db "INSERT OR IGNORE INTO tagrel(url_id,tag_id) 1222 SELECT entry.id,tag_id 1223 FROM gruik_tags LEFT OUTER JOIN gruik ON gruik_id = gruik.id 1224 LEFT OUTER JOIN entry ON gruik.url = entry.url 1225 WHERE gruik.mark=?;") 1226 mark) 1227 (exec 1228 (sql db "UPDATE gruik SET mark=-10 WHERE mark=?;") 1229 mark) 1230 (print-selection (conc "WHERE entry.id > " last-id))) 1231 (update-feed-cache mtime)) 1232 1233 (defcmd (pull-gruiks mark) 1234 "mark" "import gruiks at the given mark level" 1235 (let* ((wh (conc "WHERE url IN (SELECT url FROM gruik WHERE mark=" mark ")")) 1236 (n (query fetch-value 1237 (sql/transient db (conc "SELECT COUNT(id) FROM entry " wh))))) 1238 (if (zero? n) 1239 (pull-gruiks* (current-seconds) mark) 1240 (begin 1241 (write-line (conc vt100-alert "Conflicting gruiks:" vt100-reset)) 1242 (query 1243 (for-each-row* (lambda (id url notes) 1244 (write-line (conc id " - " vt100-entry-header url vt100-reset)) 1245 (write-line notes))) 1246 (sql db "SELECT id,url,notes FROM gruik 1247 WHERE mark=? AND url IN (SELECT url FROM entry);") 1248 mark) 1249 (write-line (conc vt100-alert "Conflicting entries:" vt100-reset)) 1250 (print-selection wh))))) 1251 1252 (defcmd (catchup-gruik) 1253 "" "skip all past unfetched gruiks" 1254 (let ((src-path (get-config "gruik-source"))) 1255 (write-line (conc "Before: " (get-config "gruik-seen"))) 1256 (when src-path 1257 (set-config "gruik-seen" (file-size src-path))) 1258 (write-line (conc "After " (get-config "gruik-seen"))))) 1259 1260 ;;;;;;;;;;;;;;;;;;;; 1261 ;; Feed Generation 1262 1263 (define (generate-feed forced feed-id filename url selector title mtime) 1264 (let* ((rows (feed-rows selector)) 1265 (generate? 1266 (cond ((null? rows) 1267 (when config-verbose 1268 (write-line (conc "Feed " feed-id " is empty"))) 1269 #f) 1270 ((any (cut = feed-id <>) dirty-feeds) 1271 (when config-verbose 1272 (write-line (conc "Generating feed " feed-id))) 1273 #t) 1274 (forced 1275 (when config-verbose 1276 (write-line (conc "Generating feed " feed-id 1277 " unconditionally"))) 1278 #t) 1279 (else 1280 (when config-verbose 1281 (write-line (conc "Feed " feed-id 1282 " is already up to date"))) 1283 #t)))) 1284 (when generate? 1285 (with-output-to-file filename 1286 (lambda () (write-feed (if (null? mtime) (list-ref (car rows) 7) mtime) 1287 title url rows))) 1288 (set! dirty-feeds (delete! feed-id dirty-feeds =)) 1289 (set! feed-cache 1290 (alist-update! feed-id 1291 (map (lambda (row) (list (car row) (list-ref row 7))) 1292 rows) 1293 feed-cache =))))) 1294 1295 (define (generate-feeds forced id-list) 1296 (for-each 1297 (lambda (row) (apply generate-feed forced row)) 1298 (if (null? id-list) 1299 (query fetch-rows 1300 (sql db "SELECT id,filename,url,selector,title,mtime 1301 FROM feed WHERE active=1;")) 1302 (map (lambda (id) 1303 (query fetch 1304 (sql db "SELECT id,filename,url,selector,title,mtime 1305 FROM feed WHERE id=?;") 1306 id)) 1307 id-list)))) 1308 1309 (defcmd (force-generate . args) 1310 "[feed-id ...]" 1311 "Generate unconditionally the given feeds, or all active feeds" 1312 (generate-feeds #t args)) 1313 1314 (defcmd (generate . args) 1315 "[feed-id ...]" "Generate if needed the given feeds, or all active feeds" 1316 (generate-feeds #f args)) 1317 1318 ;;;;;;;;;;;;; 1319 ;; Auto Add 1320 1321 (define (string-trim s) 1322 (cond 1323 ((string=? s "") s) 1324 ((char=? #\space (string-ref s 0)) 1325 (string-trim (substring s 1))) 1326 ((char=? #\space (string-ref s (sub1 (string-length s)))) 1327 (string-trim (substring s 0 (sub1 (string-length s))))) 1328 (else s))) 1329 1330 (define (get-title url) 1331 (let* ((block (with-input-from-request url #f (cut read-string 2048))) 1332 (start (substring-index-ci "<title>" block)) 1333 (end (if start (substring-index-ci "</title>" block start) #f))) 1334 (if end (string-trim (substring block (+ start 7) end)) #f))) 1335 1336 (define (auto-add lines) 1337 (unless arg-replay 1338 (trace `(auto-add ,lines)) 1339 (let loop ((index 0) (urls '())) 1340 (let* ((start0 (substring-index-ci "https://" lines index)) 1341 (start (if start0 start0 1342 (substring-index-ci "http://" lines index))) 1343 (end (if start 1344 (apply min 1345 (filter identity 1346 (list 1347 (string-length lines) 1348 (substring-index " " lines start) 1349 (substring-index "\n" lines start)))) 1350 #f)) 1351 (s-start (substring-index "[" lines index)) 1352 (s-end (if (and s-start (> start s-start)) 1353 (substring-index "]" lines s-start) 1354 #f))) 1355 (cond (start 1356 (loop end 1357 (cons (if (and s-end (> start s-end)) 1358 (list 1359 (substring lines s-start s-end) 1360 (string-trim (substring lines s-end start)) 1361 (substring lines start sed)) 1362 (let* ((url (substring lines start end)) 1363 (title (get-title url))) 1364 (if title (list '() title url) url))) 1365 urls))) 1366 ((null? urls) 1367 (write-line (conc "Warning: no URL found"))) 1368 (else 1369 (for-each (cut add-entry <> lines) urls))))))) 1370 1371 ;;;;;;;;;;;;;; 1372 ;; Main loop 1373 1374 (defcmd (replay filename) 1375 "filename" "Replay the given file" 1376 (let ((old-arg-replay arg-replay)) 1377 (set! arg-replay #t) 1378 (load filename) 1379 (set! arg-replay old-arg-replay))) 1380 1381 (define write-each-row 1382 (for-each-row 1383 (lambda (row) (if (= 1 (length row)) 1384 (write-line (->string (car row))) 1385 (begin (write row) (newline)))))) 1386 1387 (define (write-query text . args) 1388 (apply query write-each-row (sql/transient db text) args)) 1389 1390 (defcmd (help) 1391 "" "Display this help" 1392 (for-each 1393 (lambda (row) 1394 (write-line (conc 1395 "(" 1396 (car row) 1397 (if (zero? (string-length (cadr row))) "" " ") 1398 (cadr row) 1399 ")")) 1400 (write-line (conc " " (caddr row)))) 1401 cmd-list)) 1402 1403 (set! cmd-list (sort! cmd-list (lambda (r1 r2) (string<? (car r1) (car r2))))) 1404 1405 (define completion-ptr cmd-list) 1406 (define new-completion #t) 1407 (define (completer prefix state) 1408 (when (zero? state) 1409 (set! completion-ptr cmd-list) 1410 (set! new-completion #t)) 1411 (let ((buf (line-buffer))) 1412 (cond ((and (positive? (string-length buf)) 1413 (not (eqv? (string-ref buf 0) #\())) 1414 #f) 1415 ((substring-index " " buf) 1416 (let ((other-state (if new-completion 0 state))) 1417 (set! new-completion #f) 1418 (scheme-completer prefix other-state))) 1419 (else 1420 (let loop () 1421 (cond ((null? completion-ptr) 1422 #f) 1423 ((starts-with? prefix (caar completion-ptr)) 1424 (let ((result (caar completion-ptr))) 1425 (set! completion-ptr (cdr completion-ptr)) 1426 result)) 1427 (else 1428 (set! completion-ptr (cdr completion-ptr)) 1429 (loop)))))))) 1430 1431 (define state 'general) 1432 (define (prompt) 1433 (string-append 1434 (if (null? protection-overrides) 1435 "" 1436 (string-append "!" 1437 (string-intersperse (map ->string protection-overrides) ","))) 1438 (cond ((eqv? state 'general) "> ") 1439 ((eqv? state 'in-command) "… ") 1440 (else "? ")))) 1441 1442 (define (interactive-main) 1443 (basic-quote-characters-set! "\"|") 1444 (completer-word-break-characters-set! "\"\'`;|()[] ") 1445 (completer-set! completer) 1446 (variable-bind! "blink-matching-paren" "on") 1447 (paren-blink-timeout-set! 200000) 1448 1449 (let ((handler (signal-handler signal/int))) 1450 (set-signal-handler! signal/int (lambda (s) (cleanup-after-signal!) 1451 (reset-after-signal!) 1452 (handler s)))) 1453 (on-exit reset-terminal!) 1454 (current-input-port (make-readline-port prompt)) 1455 1456 (let main-loop () 1457 (let ((c (peek-char))) 1458 (cond ((eof-object? c)) 1459 ((eqv? c #\() 1460 (set! state 'in-command) 1461 (handle-exceptions 1462 exn 1463 (begin 1464 (print-error-message exn) 1465 (print-call-chain)) 1466 (eval (read))) 1467 (set! state 'general) 1468 (main-loop)) 1469 (else 1470 (let data-loop ((acc (list (read-line)))) 1471 (if (char-ready?) 1472 (data-loop (cons (read-line) acc)) 1473 (let ((lines (reverse-string-append 1474 (map terminate-line acc)))) 1475 (when (positive? (string-length lines)) 1476 (auto-add lines)) 1477 (main-loop))))))))) 1478 1479 (cond ((not arg-replay) 1480 (interactive-main)) 1481 ((eqv? (string-ref arg-replay 0) #\() 1482 (eval (read (open-input-string arg-replay)))) 1483 (else 1484 (load arg-replay)))