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