iens.scm (55761B)
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 (exec (sql db "INSERT INTO entry(url,title,source,notes,ctime,mtime) 562 VALUES (?,?,?,?,?,?);") 563 url title source notes ctime ctime)) 564 (let ((new-id (last-insert-rowid db))) 565 (exec (sql db "INSERT INTO tagrel SELECT ?,id FROM tag WHERE auto=1;") 566 new-id) 567 new-id))))) 568 (set! cur-entry new-id) 569 (write-line (conc "Added " new-id))) 570 (update-feed-cache ctime)) 571 572 (defcmd (add-entry first second . rest) 573 "[timestamp] URL note-line [note-line ...]" "Create a new entry" 574 (if (or (null? rest) (string? first) (list? first)) 575 (add-entry* (current-seconds) 576 first 577 (apply string-append (map terminate-line (cons second rest)))) 578 (add-entry* first 579 second 580 (apply string-append (map terminate-line rest))))) 581 582 (define (add-notes* mtime entry-id lines) 583 (unless (null? lines) 584 (trace `(add-notes ,mtime ,entry-id . ,lines)) 585 (with-transaction db 586 (lambda () 587 (let ((prev-notes (query fetch-value 588 (sql db "SELECT notes FROM entry WHERE id=?;") 589 entry-id))) 590 (unless-protected entry-id 591 (exec (sql db "UPDATE entry SET notes=?,mtime=? WHERE id=?;") 592 (apply string-append prev-notes 593 (map terminate-line lines)) 594 mtime 595 entry-id)))))) 596 (update-feed-cache mtime)) 597 598 (defcmd (add-notes . args) 599 "[[timestamp] entry-id] note-line [note-line ...]" 600 "Append new lines of notes" 601 (apply add-notes* (time-id-strings args))) 602 603 (define (print-entry-row id url type descr notes title source source-url 604 protected ptime ctime mtime tags) 605 (write-line (conc vt100-entry-header 606 "#" id (if (zero? protected) "" "*") " - " url 607 vt100-reset)) 608 (unless (null? ctime) (write-line (conc "Created: " (rfc-3339 ctime)))) 609 (unless (null? ptime) (write-line (conc "Protected: " (rfc-3339 ptime)))) 610 (unless (null? mtime) (write-line (conc "Modified: " (rfc-3339 mtime)))) 611 (unless (null? title) (write-line (conc "Title: " title))) 612 (if (null? source) 613 (unless (null? source-url) 614 (write-line (conc "Orphan source URL: " source-url))) 615 (write-line (conc "from " source 616 (if (null? source-url) "" (conc " " source-url))))) 617 (unless (null? descr) 618 (if (null? type) 619 (write-line "Description:") 620 (write-line (conc "Description (" type "):"))) 621 (write-string descr)) 622 (unless (null? notes) 623 (write-line (conc "Notes:")) 624 (write-string notes)) 625 (if (null? tags) 626 (write-line "No tags.") 627 (write-line (string-append "Tags: " tags)))) 628 629 (define (print-listed-entry-row id url notes protected) 630 (write-line (conc vt100-entry-header 631 "#" id (if (zero? protected) "" "*") " - " url 632 vt100-reset)) 633 (write-string notes)) 634 635 (define (count-selection* id name text) 636 (write-line (string-append (if id (conc "#" id ": ") "") 637 "\"" name "\"")) 638 (write-line (conc " -> " (query fetch-value 639 ((if id sql sql/transient) 640 db 641 (string-append 642 "SELECT COUNT(id) FROM entry " 643 text ";")))))) 644 645 (defcmd (count-selection . args) 646 "\"WHERE ...\"|selector-id ..." "Count results of a custom queries" 647 (if (null? args) 648 (query (for-each-row* count-selection*) 649 (sql db "SELECT id,name,text FROM selector;")) 650 (let loop ((todo args)) 651 (unless (null? todo) 652 (call-with-selector (car todo) count-selection*) 653 (loop (cdr todo)))))) 654 655 (defcmd (list-selection arg) 656 "\"WHERE ...\"|selector-id" "Display a custom query as an entry list" 657 (call-with-selector arg 658 (lambda (id title selector) 659 (query (for-each-row* print-listed-entry-row) 660 ((if id sql sql/transient) db 661 (string-append "SELECT id,url,notes,protected FROM entry " 662 selector ";")))))) 663 664 (defcmd (list-tagged tag-name #!optional (count config-list-tagged-count)) 665 "tag-name [limit]" "Display entries with the given tag" 666 (query (for-each-row* print-listed-entry-row) 667 (sql db (cond ((positive? count) 668 "SELECT * FROM 669 (SELECT id,url,notes,protected FROM entry 670 WHERE id IN (SELECT url_id FROM tagrel 671 WHERE tag_id IN (SELECT id FROM tag 672 WHERE name=?)) 673 ORDER BY id DESC LIMIT ?) 674 ORDER BY id ASC;") 675 ((negative? count) 676 "SELECT id,url,notes,protected FROM entry 677 WHERE id IN (SELECT url_id FROM tagrel 678 WHERE tag_id IN (SELECT id FROM tag 679 WHERE name=?)) 680 ORDER BY id ASC LIMIT ?;") 681 (else ; (zero? count) 682 "SELECT id,url,notes,protected FROM entry 683 WHERE id IN (SELECT url_id FROM tagrel 684 WHERE tag_id IN (SELECT id FROM tag 685 WHERE name=?)) 686 OR id=? 687 ORDER BY id ASC;"))) 688 tag-name 689 (abs count))) 690 691 (defcmd (list-untagged) 692 "" "Display entries without any tag" 693 (query (for-each-row* print-listed-entry-row) 694 (sql db "SELECT id,url,notes,protected FROM entry 695 WHERE id NOT IN (SELECT url_id FROM tagrel);"))) 696 697 (define (print-entry* entry-id) 698 (query (for-each-row* print-entry-row) 699 (sql db "SELECT entry.id, url, type, description, notes, 700 title, source, source_url, protected, 701 ptime, ctime, mtime, group_concat(tag.name, ' ') 702 FROM entry 703 LEFT OUTER JOIN tagrel ON entry.id=tagrel.url_id 704 LEFT OUTER JOIN tag ON tag.id=tagrel.tag_id 705 WHERE entry.id=? GROUP BY entry.id;") 706 entry-id)) 707 708 (defcmd (print-entry . args) 709 "[entry-id]" "Display an entry" 710 (if (null? args) 711 (print-entry* cur-entry) 712 (let loop ((todo args)) 713 (unless (null? todo) 714 (print-entry* (car todo)) 715 (loop (cdr todo)))))) 716 717 (defcmd (print-selection arg) 718 "\"WHERE ...\"|selector-id" "Display entries from a custom query" 719 (call-with-selector arg 720 (lambda (id title selector) 721 (query 722 (for-each-row* print-entry-row) 723 ((if id sql sql/transient) db 724 (string-append 725 "SELECT entry.id, url, type, description, notes, 726 title, source, source_url, protected, 727 ptime, ctime, mtime, group_concat(tag.name, ' ') 728 FROM entry 729 LEFT OUTER JOIN tagrel ON entry.id=tagrel.url_id 730 LEFT OUTER JOIN tag ON tag.id=tagrel.tag_id " 731 selector 732 " GROUP BY entry.id;")))))) 733 734 (defcmd (random-tagged tag-name) 735 "tag" "Select a random entry with the given tag" 736 (let ((entry-id (query fetch-value 737 (sql db "SELECT url_id FROM tagrel WHERE tag_id IN 738 (SELECT id FROM tag WHERE name=?) 739 ORDER BY RANDOM() LIMIT 1;") 740 tag-name))) 741 (if entry-id 742 (begin 743 (set! cur-entry entry-id) 744 (print-entry)) 745 (write-line "No such entry found")))) 746 747 (defcmd (random-untagged) 748 "" "Select a random entry without tag" 749 (let ((entry-id (query fetch-value 750 (sql db "SELECT id FROM entry WHERE id NOT IN 751 (SELECT url_id FROM tagrel) 752 ORDER BY RANDOM() LIMIT 1;")))) 753 (if entry-id 754 (begin 755 (set! cur-entry entry-id) 756 (print-entry)) 757 (write-line "No such entry found")))) 758 759 (define (guess-type str) 760 (cond ((null? str) '()) 761 ((starts-with? "<" str) "html") 762 ((or (starts-with? " - " str) 763 (starts-with? " + " str)) "markdown-li") 764 (else "text"))) 765 766 (define (set-descr* mtime entry-id type text) 767 (trace `(set-descr ,mtime ,entry-id ,type ,text)) 768 (unless-protected entry-id 769 (exec (sql db "UPDATE entry SET type=?,description=?,mtime=? WHERE id=?;") 770 type text mtime entry-id) 771 (update-feed-cache mtime))) 772 773 (defcmd (set-descr first . args) 774 "[[[mtime] entry-id] type] description" "Sets an entry description" 775 (case (length args) 776 ((0) (set-descr* (current-seconds) cur-entry (guess-type first) first)) 777 ((1) (set-descr* (current-seconds) cur-entry first (car args))) 778 ((2) (set-descr* (current-seconds) first (car args) (cadr args))) 779 ((3) (set-descr* first (car args) (cadr args) (caddr args))) 780 (else (assert #f "Too many arguments to set-descr " (cons first args))))) 781 782 (define (set-source* mtime entry-id source source-url) 783 (trace `(set-source ,mtime ,entry-id ,source ,source-url)) 784 (unless-protected entry-id 785 (exec (sql db "UPDATE entry 786 SET source=?, source_url=COALESCE(?,source_url), mtime=? 787 WHERE id=?;") 788 source source-url mtime entry-id))) 789 790 (defcmd (set-source first . args) 791 "[[mtime] entry-id] source [source-URL]" "Sets entry source" 792 (case (length args) 793 ((0) (set-source* (current-seconds) cur-entry first '())) 794 ((1) (cond 795 ((string? (car args)) 796 (set-source* (current-seconds) cur-entry first (car args))) 797 ((number? (car args)) 798 (set-source* (current-seconds) first (car args) '())) 799 (else (assert #f "Unsupported arg types in " (cons first args))))) 800 ((2) (cond 801 ((string? (cadr args)) 802 (set-source* (current-seconds) first (car args) (cadr args))) 803 ((number? (cadr args)) 804 (set-source* first (car args) (cadr args) '())) 805 (else (assert #f "Unsupported arg types in " (cons first args))))) 806 ((3) (set-descr* first (car args) (cadr args) (caddr args))) 807 (else (assert #f "Too many arguments to set-source " (cons first args))))) 808 809 (define (set-title* mtime entry-id title) 810 (trace `(set-title ,mtime ,entry-id ,title)) 811 (unless-protected entry-id 812 (exec (sql db "UPDATE entry SET title=?, mtime=? WHERE id=?;") 813 title mtime entry-id))) 814 815 (defcmd (set-title first . args) 816 "[[mtime] entry-id] title" "Sets entry title" 817 (case (length args) 818 ((0) (set-title* (current-seconds) cur-entry first)) 819 ((1) (set-title* (current-seconds) first (car args))) 820 ((2) (set-title* first (car args) (cadr args))) 821 (else (assert #f "Too many arguments to set-title " (cons first args))))) 822 823 (defcmd (set-entry arg) 824 "entry-id|url" "Set current entry" 825 (cond ((integer? arg) 826 (set! cur-entry arg) 827 (when config-verbose (print-entry))) 828 ((string? arg) 829 (let ((id (query fetch-value 830 (sql db "SELECT id FROM entry WHERE url=?;") 831 arg))) 832 (if id 833 (begin 834 (set! cur-entry id) 835 (when config-verbose (print-entry))) 836 (write-line (conc "No entry found for \"" arg "\""))))) 837 (else (assert #f "Unsupported argument type for " arg)))) 838 839 (define (touch* mtime entry-id) 840 (trace `(touch ,mtime ,entry-id)) 841 (unless-protected entry-id 842 (exec (sql db "UPDATE entry SET mtime=? WHERE id=?;") mtime entry-id) 843 (update-feed-cache mtime))) 844 845 (define (touch . args) 846 (cond ((null? args) 847 (touch* (current-seconds) cur-entry)) 848 ((not (integer? (car args))) 849 (assert #f "Bad type for " (car args))) 850 ((null? (cdr args)) 851 (touch* (current-seconds) (car args))) 852 ((not (integer? (cadr args))) 853 (assert #f "Bad type for " (car args))) 854 (else 855 (touch* (car args) (cadr args))))) 856 857 (define (without-mtime* entry-id proc) 858 (if (or (procedure? proc) (list? proc)) 859 (let ((prev-entry cur-entry) 860 (prev-mtime (query fetch-value 861 (sql db "SELECT mtime FROM entry WHERE id=?;") 862 entry-id))) 863 (set! cur-entry entry-id) 864 (if (procedure? proc) (proc) (eval proc)) 865 (touch* prev-mtime entry-id) 866 (set! cur-entry prev-entry)) 867 (write-line (conc "Invalid procedure " proc)))) 868 869 (defcmd (without-mtime! first . args) 870 "[entry-id] '(...)" "Perform updates and restore entry mtime" 871 (cond ((null? args) 872 (without-mtime* cur-entry first)) 873 ((and (null? (cdr args)) (integer? first)) 874 (without-mtime* first (car args))) 875 (else (assert #f "Invalid arguments " (cons first args))))) 876 877 ;; Entry Tagging 878 879 (define (print-tags* entry-id) 880 (write-line (apply conc (append (list "Tags for " entry-id ":") 881 (query (map-rows (lambda (x) (string-append " " (car x)))) 882 (sql db "SELECT tag.name FROM tagrel 883 OUTER LEFT JOIN tag ON tagrel.tag_id=tag.id 884 WHERE url_id=? ORDER BY tag.name;") 885 entry-id))))) 886 887 (defcmd (print-tags . args) 888 "[entry-id ...]" "Print tags associated with an entry" 889 (if (null? args) 890 (print-tags* cur-entry) 891 (let loop ((todo args)) 892 (unless (null? todo) 893 (print-tags* (car todo)) 894 (loop (cdr todo)))))) 895 896 897 (define (resolve-tag-id tag-name) 898 (let ((result (query fetch-value 899 (sql db "SELECT id from tag WHERE name=?;") 900 tag-name))) 901 (unless result 902 (write-line (conc "Unknown tag " tag-name))) 903 result)) 904 905 (define (exec-on-tags stmt mtime entry-id tag-list) 906 (with-transaction db 907 (lambda () 908 (unless-protected entry-id 909 (let ((tag-id-list (map resolve-tag-id tag-list))) 910 (when (every identity tag-id-list) 911 (let loop ((todo tag-id-list)) 912 (if (null? todo) 913 (exec (sql db "UPDATE entry SET mtime=? WHERE id=?;") 914 mtime entry-id) 915 (begin 916 (exec stmt entry-id (car todo)) 917 (loop (cdr todo)))))))))) 918 (print-tags entry-id) 919 (update-feed-cache mtime)) 920 921 (define (retag* mtime entry-id tag-list) 922 (trace `(retag ,mtime ,entry-id . ,tag-list)) 923 (unless-protected entry-id 924 (exec (sql db "DELETE FROM tagrel WHERE url_id=?;") entry-id) 925 (exec-on-tags (sql db "INSERT OR IGNORE INTO tagrel VALUES (?,?);") 926 mtime entry-id tag-list))) 927 928 (defcmd (retag . args) 929 "[[timestamp] entry-id] tag-name [tag-name ...]" 930 "Overwrite tag list for an entry" 931 (apply retag* (time-id-strings args))) 932 933 (define (tag* mtime entry-id tag-list) 934 (unless (null? tag-list) 935 (trace `(tag ,mtime ,entry-id . ,tag-list)) 936 (exec-on-tags (sql db "INSERT OR IGNORE INTO tagrel VALUES (?,?);") 937 mtime entry-id tag-list))) 938 939 (defcmd (tag . args) 940 "[[timestamp] entry-id] tag-name [tag-name ...]" 941 "Associate tags to an entry" 942 (apply tag* (time-id-strings args))) 943 944 (define (untag* mtime entry-id tag-list) 945 (unless (null? tag-list) 946 (trace `(untag ,mtime ,entry-id . ,tag-list)) 947 (exec-on-tags (sql db "DELETE FROM tagrel WHERE url_id=? AND tag_id=?;") 948 mtime entry-id tag-list))) 949 950 (defcmd (untag . args) 951 "[[timestamp] entry-id] tag-name [tag-name ...]" 952 "Disssociates tags from an entry" 953 (apply untag* (time-id-strings args))) 954 955 ;;;;;;;;;;;;;;;;;;;; 956 ;; Editor Spawning 957 958 (define (edit-descr* entry-id) 959 (let ((file-name (create-temporary-file 960 (string-append "." 961 (get-config/default "description-ext" "txt")))) 962 (fields 963 (query fetch-row 964 (sql db "SELECT description,notes,url FROM entry WHERE id=?;") 965 entry-id))) 966 (unless (null? fields) 967 (call-with-output-file file-name 968 (lambda (port) 969 (if (or (null? (car fields)) (string=? (car fields) "")) 970 (let* ((s-sec (substring-index "[" (cadr fields))) 971 (e-sec (if s-sec 972 (substring-index "]" (cadr fields) s-sec) 973 #f)) 974 (sect (if e-sec 975 (substring (cadr fields) (+ s-sec 1) e-sec) #f)) 976 (comm (if sect (comment-link sect (caddr fields)) #f))) 977 (write-string (conc " + [](" (caddr fields) ")\n") #f port) 978 (when sect 979 (write-string 980 (conc "(via " 981 (if comm (conc "[" sect "](" comm ")") sect) 982 " sur #gcufeed)\n") 983 #f port))) 984 (write-string (car fields) #f port)) 985 (unless (null? (cadr fields)) 986 (write-string "-+-+-\n" #f port) 987 (write-string (cadr fields) #f port))))) 988 (when config-editor 989 (process-wait 990 (process-run (string-append config-editor " " (qs file-name))))) 991 (let ((result (call-with-input-file file-name 992 (lambda (port) 993 (let* ((text (read-string #f port)) 994 (end (substring-index-ci "-+-+-\n" text))) 995 (if end 996 (substring text 0 end) 997 text)))))) 998 (delete-file file-name) 999 (if (or (zero? (string-length result)) 1000 (equal? (if (or (null? fields) (null? (car fields))) 1001 "" (car fields)) 1002 result)) 1003 #f 1004 result)))) 1005 1006 1007 (defcmd (edit-descr . args) 1008 "[[mtime] entry-id]" "Describe using an external editor" 1009 (let ((new-value (case (length args) 1010 ((0) (edit-descr* cur-entry)) 1011 ((1) (edit-descr* (car args))) 1012 ((2) (edit-descr* (cadr args))) 1013 (else 1014 (assert #f "Too many arguments to edit-descr " args))))) 1015 (when new-value 1016 (case (length args) 1017 ((0) (set-descr* (current-seconds) 1018 cur-entry 1019 (guess-type new-value) 1020 new-value)) 1021 ((1) (set-descr* (current-seconds) 1022 (car args) 1023 (guess-type new-value) 1024 new-value)) 1025 ((2) (set-descr* (car args) 1026 (cadr args) 1027 (guess-type new-value) 1028 new-value)) 1029 (else (assert #f "Too many arguments to edit-descr " args)))))) 1030 1031 (define (auto-cols widths avail) 1032 (letrec ((len (vector-length widths)) 1033 (w-slice (lambda (start len acc) 1034 (if (< len 1) 1035 acc 1036 (w-slice (+ start 1) (- len 1) 1037 (max acc (vector-ref widths start)))))) 1038 (w-total (lambda (start stride acc) 1039 (if (< (+ start stride) len) 1040 (w-total (+ start stride) 1041 stride 1042 (cons (+ (car acc) 1 (w-slice start stride 0)) 1043 acc)) 1044 (cons (+ (car acc) (w-slice start (- len start) 0)) 1045 acc)))) 1046 (h-cols (lambda (ncols) (quotient (+ len ncols -1) ncols))) 1047 (w-cols (lambda (ncols) (w-total 0 (h-cols ncols) (list 0))))) 1048 (let loop ((ncols len) (best #f)) 1049 (if (zero? ncols) best 1050 (let ((w (w-cols ncols)) (h (h-cols ncols))) 1051 (loop (- ncols 1) 1052 (if (and (< (car w) avail) 1053 (or (not best) (<= h (car best)))) 1054 (list h (list->vector (reverse (cdr w)))) 1055 best))))))) 1056 1057 (define (select-tags** entry-id tags) 1058 (let* ((ntags (vector-length tags)) 1059 (state (list->vector (map cadddr (vector->list tags)))) 1060 (cols (auto-cols (list->vector 1061 (map (lambda (x) 1062 (+ (string-length (cadr x)) 1063 (string-length (caddr x)))) 1064 (vector->list tags))) (COLS))) 1065 (stride (car cols)) 1066 (x-cols (cadr cols)) 1067 (show-tag (lambda (index sel) 1068 (unless (zero? (vector-ref state index)) 1069 ; (attron (COLOR_PAIR 1))) 1070 (attron A_REVERSE)) 1071 (when (= index sel) 1072 ; (attron A_REVERSE)) 1073 (attron A_UNDERLINE)) 1074 (mvprintw 1075 (remainder index stride) 1076 (vector-ref x-cols (quotient index stride)) 1077 "~A~A" 1078 (cadr (vector-ref tags index)) 1079 (caddr (vector-ref tags index))) 1080 (when (= index sel) 1081 ; (attroff A_REVERSE)) 1082 (attroff A_UNDERLINE)) 1083 (unless (zero? (vector-ref state index)) 1084 ; (attroff (COLOR_PAIR 1))))) 1085 (attroff A_REVERSE)))) 1086 (update-tags (lambda (old new) (show-tag old new) (show-tag new new)))) 1087 (keypad (stdscr) #t) 1088 (noecho) 1089 (curs_set 0) 1090 ; (start_color) 1091 ; (init_pair 1 COLOR_BLUE COLOR_BLACK) 1092 (let init ((index 0)) 1093 (when (< index ntags) 1094 (show-tag index 0) 1095 (init (+ index 1)))) 1096 (let loop ((sel 0)) 1097 (let ((c (char->integer (getch)))) 1098 (cond 1099 ((= c KEY_UP) 1100 (let ((next-sel (modulo (- sel 1) ntags))) 1101 (update-tags sel next-sel) 1102 (loop next-sel))) 1103 ((= c KEY_DOWN) 1104 (let ((next-sel (modulo (+ sel 1) ntags))) 1105 (update-tags sel next-sel) 1106 (loop next-sel))) 1107 ((= c KEY_LEFT) 1108 (let ((next-sel (if (>= sel stride) 1109 (- sel stride) 1110 (min (+ sel (- ntags (modulo ntags stride))) 1111 (- ntags 1))))) 1112 (update-tags sel next-sel) 1113 (loop next-sel))) 1114 ((= c KEY_RIGHT) 1115 (let ((next-sel (cond ((< (+ sel stride) ntags) 1116 (+ sel stride)) 1117 ((< sel (- ntags (modulo ntags stride))) 1118 (- ntags 1)) 1119 (else (modulo sel stride))))) 1120 (update-tags sel next-sel) 1121 (loop next-sel))) 1122 ((= c 32) 1123 (vector-set! state sel (- 1 (vector-ref state sel))) 1124 (show-tag sel sel) 1125 (loop sel)) 1126 ((= c 10) 1127 (let result ((index 0) (add '()) (del '())) 1128 (cond 1129 ((>= index ntags) 1130 (list add del)) 1131 ((= (cadddr (vector-ref tags index)) (vector-ref state index)) 1132 (result (+ index 1) add del)) 1133 ((zero? (vector-ref state index)) 1134 (result (+ index 1) add 1135 (cons (cadr (vector-ref tags index)) del))) 1136 (else 1137 (result (+ index 1) 1138 (cons (cadr (vector-ref tags index)) add) 1139 del))))) 1140 ((= c 27) '(()())) 1141 ((or (<= 65 c 90) (<= 97 c 122)) 1142 (let search ((prev-sel sel) 1143 (prev-ch (char->integer (string-ref 1144 (cadr (vector-ref tags sel)) 0)))) 1145 (let* ((next-sel (modulo (+ prev-sel 1) ntags)) 1146 (next-ch (char->integer (string-ref 1147 (cadr (vector-ref tags next-sel)) 0)))) 1148 (cond 1149 ((= next-sel sel) 1150 (loop sel)) 1151 ((or (= next-ch c) (< prev-ch c next-ch)) 1152 (update-tags sel next-sel) 1153 (loop next-sel)) 1154 (else (search next-sel next-ch)))))) 1155 (else (mvprintw (+ 1 stride) 0 "~S ~S" KEY_DOWN c) (loop sel))))))) 1156 1157 (define (select-tags* entry-id) 1158 (if (update-allowed? entry-id) 1159 (let ((tags (list->vector (query 1160 (map-rows* (lambda (id name count active) 1161 (list id name (conc " (" count ")") 1162 active))) 1163 (sql db 1164 "SELECT id,name,COUNT(url_id),COALESCE(MAX(url_id==?),0) 1165 FROM tag LEFT OUTER JOIN tagrel ON tag_id=tag.id 1166 GROUP BY tag.name;") 1167 entry-id)))) 1168 (dynamic-wind initscr (lambda () (select-tags** entry-id tags)) endwin)) 1169 '(()()))) 1170 1171 (defcmd (select-tags . args) 1172 "[[mtime] entry-id]" "Interactively select tags using dialog(1)" 1173 (let* ((entry-id (case (length args) 1174 ((0) cur-entry) 1175 ((1) (car args)) 1176 ((2) (cadr args)) 1177 (else 1178 (assert #f "Too many arguments to select-tags " args)))) 1179 (mtime (if (= 2 (length args)) (car args) (current-seconds))) 1180 (changes (select-tags* entry-id)) 1181 (added (car changes)) 1182 (removed (cadr changes))) 1183 (unless-protected entry-id 1184 (untag* (- mtime 1) entry-id removed) 1185 (tag* mtime entry-id added)))) 1186 1187 ;;;;;;;;;;;;;;;;;;;;; 1188 ;; Gruik Management 1189 1190 (define (pull-gruiks* mtime mark) 1191 (let ((last-id (query fetch-value (sql db "SELECT MAX(id) FROM entry;")))) 1192 (exec 1193 (sql db "INSERT OR IGNORE 1194 INTO entry(url,type,description,notes,ctime,mtime) 1195 SELECT url, 1196 CASE WHEN description IS NULL THEN NULL 1197 WHEN substr(description,1,1)='<' THEN 'html' 1198 WHEN substr(description,1,3)=' - ' 1199 OR substr(description,1,3)=' + ' THEN 'markdown-li' 1200 ELSE 'text' END, 1201 trim(description,char(10))||char(10), 1202 trim(notes,char(10))||char(10), 1203 stime,? 1204 FROM gruik 1205 WHERE mark=? AND url NOT IN (SELECT url FROM entry);") 1206 mtime 1207 mark) 1208 (exec 1209 (sql db "INSERT OR IGNORE INTO tagrel(url_id,tag_id) 1210 SELECT entry.id,tag_id 1211 FROM gruik_tags LEFT OUTER JOIN gruik ON gruik_id = gruik.id 1212 LEFT OUTER JOIN entry ON gruik.url = entry.url 1213 WHERE gruik.mark=?;") 1214 mark) 1215 (exec 1216 (sql db "UPDATE gruik SET mark=-10 WHERE mark=?;") 1217 mark) 1218 (print-selection (conc "WHERE entry.id > " last-id))) 1219 (update-feed-cache mtime)) 1220 1221 (defcmd (pull-gruiks mark) 1222 "mark" "import gruiks at the given mark level" 1223 (let* ((wh (conc "WHERE url IN (SELECT url FROM gruik WHERE mark=" mark ")")) 1224 (n (query fetch-value 1225 (sql/transient db (conc "SELECT COUNT(id) FROM entry " wh))))) 1226 (if (zero? n) 1227 (pull-gruiks* (current-seconds) mark) 1228 (begin 1229 (write-line (conc vt100-alert "Conflicting gruiks:" vt100-reset)) 1230 (query 1231 (for-each-row* (lambda (id url notes) 1232 (write-line (conc id " - " vt100-entry-header url vt100-reset)) 1233 (write-line notes))) 1234 (sql db "SELECT id,url,notes FROM gruik 1235 WHERE mark=? AND url IN (SELECT url FROM entry);") 1236 mark) 1237 (write-line (conc vt100-alert "Conflicting entries:" vt100-reset)) 1238 (print-selection wh))))) 1239 1240 (defcmd (catchup-gruik) 1241 "" "skip all past unfetched gruiks" 1242 (let ((src-path (get-config "gruik-source"))) 1243 (write-line (conc "Before: " (get-config "gruik-seen"))) 1244 (when src-path 1245 (set-config "gruik-seen" (file-size src-path))) 1246 (write-line (conc "After " (get-config "gruik-seen"))))) 1247 1248 ;;;;;;;;;;;;;;;;;;;; 1249 ;; Feed Generation 1250 1251 (define (generate-feed forced feed-id filename url selector title mtime) 1252 (let* ((rows (feed-rows selector)) 1253 (generate? 1254 (cond ((null? rows) 1255 (when config-verbose 1256 (write-line (conc "Feed " feed-id " is empty"))) 1257 #f) 1258 ((any (cut = feed-id <>) dirty-feeds) 1259 (when config-verbose 1260 (write-line (conc "Generating feed " feed-id))) 1261 #t) 1262 (forced 1263 (when config-verbose 1264 (write-line (conc "Generating feed " feed-id 1265 " unconditionally"))) 1266 #t) 1267 (else 1268 (when config-verbose 1269 (write-line (conc "Feed " feed-id 1270 " is already up to date"))) 1271 #t)))) 1272 (when generate? 1273 (with-output-to-file filename 1274 (lambda () (write-feed (if (null? mtime) (list-ref (car rows) 7) mtime) 1275 title url rows))) 1276 (set! dirty-feeds (delete! feed-id dirty-feeds =)) 1277 (set! feed-cache 1278 (alist-update! feed-id 1279 (map (lambda (row) (list (car row) (list-ref row 7))) 1280 rows) 1281 feed-cache =))))) 1282 1283 (define (generate-feeds forced id-list) 1284 (for-each 1285 (lambda (row) (apply generate-feed forced row)) 1286 (if (null? id-list) 1287 (query fetch-rows 1288 (sql db "SELECT id,filename,url,selector,title,mtime 1289 FROM feed WHERE active=1;")) 1290 (map (lambda (id) 1291 (query fetch 1292 (sql db "SELECT id,filename,url,selector,title,mtime 1293 FROM feed WHERE id=?;") 1294 id)) 1295 id-list)))) 1296 1297 (defcmd (force-generate . args) 1298 "[feed-id ...]" 1299 "Generate unconditionally the given feeds, or all active feeds" 1300 (generate-feeds #t args)) 1301 1302 (defcmd (generate . args) 1303 "[feed-id ...]" "Generate if needed the given feeds, or all active feeds" 1304 (generate-feeds #f args)) 1305 1306 ;;;;;;;;;;;;; 1307 ;; Auto Add 1308 1309 (define (string-trim s) 1310 (cond 1311 ((string=? s "") s) 1312 ((char=? #\space (string-ref s 0)) 1313 (string-trim (substring s 1))) 1314 ((char=? #\space (string-ref s (sub1 (string-length s)))) 1315 (string-trim (substring s 0 (sub1 (string-length s))))) 1316 (else s))) 1317 1318 (define (auto-add lines) 1319 (unless arg-replay 1320 (trace `(auto-add ,lines)) 1321 (let loop ((index 0) (urls '())) 1322 (let* ((start0 (substring-index-ci "https://" lines index)) 1323 (start (if start0 start0 1324 (substring-index-ci "http://" lines index))) 1325 (end (if start 1326 (apply min 1327 (filter identity 1328 (list 1329 (string-length lines) 1330 (substring-index " " lines start) 1331 (substring-index "\n" lines start)))) 1332 #f)) 1333 (s-start (substring-index "[" lines index)) 1334 (s-end (if (and s-start (> start s-start)) 1335 (substring-index "]" lines s-start) 1336 #f))) 1337 (cond (start 1338 (loop end 1339 (cons (if (and s-end (> start s-end)) 1340 (list 1341 (substring lines s-start s-end) 1342 (string-trim (substring lines s-end start)) 1343 (substring lines start sed)) 1344 (substring lines start end)) 1345 urls))) 1346 ((null? urls) 1347 (write-line (conc "Warning: no URL found"))) 1348 (else 1349 (for-each (cut add-entry <> lines) urls))))))) 1350 1351 ;;;;;;;;;;;;;; 1352 ;; Main loop 1353 1354 (defcmd (replay filename) 1355 "filename" "Replay the given file" 1356 (let ((old-arg-replay arg-replay)) 1357 (set! arg-replay #t) 1358 (load filename) 1359 (set! arg-replay old-arg-replay))) 1360 1361 (define write-each-row 1362 (for-each-row 1363 (lambda (row) (if (= 1 (length row)) 1364 (write-line (->string (car row))) 1365 (begin (write row) (newline)))))) 1366 1367 (define (write-query text . args) 1368 (apply query write-each-row (sql/transient db text) args)) 1369 1370 (defcmd (help) 1371 "" "Display this help" 1372 (for-each 1373 (lambda (row) 1374 (write-line (conc 1375 "(" 1376 (car row) 1377 (if (zero? (string-length (cadr row))) "" " ") 1378 (cadr row) 1379 ")")) 1380 (write-line (conc " " (caddr row)))) 1381 cmd-list)) 1382 1383 (set! cmd-list (sort! cmd-list (lambda (r1 r2) (string<? (car r1) (car r2))))) 1384 1385 (define completion-ptr cmd-list) 1386 (define new-completion #t) 1387 (define (completer prefix state) 1388 (when (zero? state) 1389 (set! completion-ptr cmd-list) 1390 (set! new-completion #t)) 1391 (let ((buf (line-buffer))) 1392 (cond ((and (positive? (string-length buf)) 1393 (not (eqv? (string-ref buf 0) #\())) 1394 #f) 1395 ((substring-index " " buf) 1396 (let ((other-state (if new-completion 0 state))) 1397 (set! new-completion #f) 1398 (scheme-completer prefix other-state))) 1399 (else 1400 (let loop () 1401 (cond ((null? completion-ptr) 1402 #f) 1403 ((starts-with? prefix (caar completion-ptr)) 1404 (let ((result (caar completion-ptr))) 1405 (set! completion-ptr (cdr completion-ptr)) 1406 result)) 1407 (else 1408 (set! completion-ptr (cdr completion-ptr)) 1409 (loop)))))))) 1410 1411 (define state 'general) 1412 (define (prompt) 1413 (string-append 1414 (if (null? protection-overrides) 1415 "" 1416 (string-append "!" 1417 (string-intersperse (map ->string protection-overrides) ","))) 1418 (cond ((eqv? state 'general) "> ") 1419 ((eqv? state 'in-command) "… ") 1420 (else "? ")))) 1421 1422 (define (interactive-main) 1423 (basic-quote-characters-set! "\"|") 1424 (completer-word-break-characters-set! "\"\'`;|()[] ") 1425 (completer-set! completer) 1426 (variable-bind! "blink-matching-paren" "on") 1427 (paren-blink-timeout-set! 200000) 1428 1429 (let ((handler (signal-handler signal/int))) 1430 (set-signal-handler! signal/int (lambda (s) (cleanup-after-signal!) 1431 (reset-after-signal!) 1432 (handler s)))) 1433 (on-exit reset-terminal!) 1434 (current-input-port (make-readline-port prompt)) 1435 1436 (let main-loop () 1437 (let ((c (peek-char))) 1438 (cond ((eof-object? c)) 1439 ((eqv? c #\() 1440 (set! state 'in-command) 1441 (handle-exceptions 1442 exn 1443 (begin 1444 (print-error-message exn) 1445 (print-call-chain)) 1446 (eval (read))) 1447 (set! state 'general) 1448 (main-loop)) 1449 (else 1450 (let data-loop ((acc (list (read-line)))) 1451 (if (char-ready?) 1452 (data-loop (cons (read-line) acc)) 1453 (let ((lines (reverse-string-append 1454 (map terminate-line acc)))) 1455 (when (positive? (string-length lines)) 1456 (auto-add lines)) 1457 (main-loop))))))))) 1458 1459 (cond ((not arg-replay) 1460 (interactive-main)) 1461 ((eqv? (string-ref arg-replay 0) #\() 1462 (eval (read (open-input-string arg-replay)))) 1463 (else 1464 (load arg-replay)))