iens

Manager of links to read
git clone https://git.instinctive.eu/iens.git
Log | Files | Refs | README | LICENSE

iens.scm (48891B)


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