iens

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

commit 4f7ad1f1d83ff39a82cbd3082ed3d08f97a46c75
parent b741ff38548a27ef2df318e0bb5b792ab6bfc875
Author: Natasha Kerensikova <natgh@instinctive.eu>
Date:   Thu, 28 Dec 2023 14:58:01 +0000

Second draft
Diffstat:
Msrc/iens.scm | 300++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-----------------
1 file changed, 237 insertions(+), 63 deletions(-)

diff --git a/src/iens.scm b/src/iens.scm @@ -2,11 +2,29 @@ (chicken process signal) (chicken process-context) (chicken io) + (chicken sort) (chicken string) + (chicken time) breadline sql-de-lite srfi-1) +(define (terminate-line line) + (let ((l (string-length line))) + (if (or (= l 0) + (eqv? (string-ref line (sub1 l)) #\newline)) + line + (string-append line "\n")))) + +(define cmd-list '()) + +(define-syntax defcmd + (syntax-rules () + ((defcmd (name . args) str first . rest) + (begin + (set! cmd-list (cons (list (symbol->string 'name) str first) cmd-list)) + (define (name . args) . rest))))) + ;;;;;;;;;;;;; ;; Tracing @@ -36,15 +54,16 @@ (write-line (conc "Initializing database with schema v" schema-version)) (for-each (lambda (s) (exec (sql db s))) - (list "CREATE TABLE config (key TEXT, val TEXT);" + (list "CREATE TABLE config (key TEXT, val);" (conc "INSERT INTO config(key, val) VALUES " - "('schema-version','" schema-version "');") + "('schema-version'," schema-version ");") (conc "CREATE TABLE tag (id INTEGER PRIMARY KEY, " - "name TEXT, auto INTEGER DEFAULT 0);") + "name TEXT NOT NULL, auto INTEGER DEFAULT 0);") (conc "CREATE TABLE entry (id INTEGER PRIMARY KEY, " "url TEXT NOT NULL, type TEXT, description TEXT, notes TEXT, " - "ctime TEXT DEFAULT CURRENT_TIMESTAMP, " - "mtime TEXT DEFAULT CURRENT_TIMESTAMP);") + "protected INTEGER DEFAULT 0, ptime INTEGER, " + "ctime INTEGER NOT NULL DEFAULT CURRENT_TIMESTAMP, " + "mtime INTEGER NOT NULL DEFAULT CURRENT_TIMESTAMP);") (conc "CREATE TABLE tagrel " "(url_id REFERENCES entry(id) " "ON UPDATE CASCADE ON DELETE CASCADE, " @@ -61,7 +80,7 @@ (define add-tag-stmt (sql db "INSERT INTO tag(name) VALUES (?);")) -(define print-tags-stmt +(define list-tags-stmt (sql db "SELECT name, auto FROM tag;")) (define remove-tag-stmt (sql db "DELETE FROM tag WHERE name = ?;")) @@ -72,19 +91,22 @@ (define set-auto-tag-stmt (sql db "UPDATE tag SET auto = ? WHERE name = ?;")) -(define (add-auto-tag name . rest) +(defcmd (add-auto-tag name . rest) + "tag-name [tag-name ...]" "Set tags as automatic" (trace `(add-auto-tag ,name)) (exec set-auto-tag-stmt 1 name) (unless (null? rest) (apply add-auto-tag rest))) -(define (add-tag name . rest) +(defcmd (add-tag name . rest) + "tag-name [tag-name ...]" "Create a new tag" (trace `(add-tag ,name)) (exec add-tag-stmt name) (unless (null? rest) (apply add-tag rest))) -(define (auto-tags . tag-list) +(defcmd (auto-tags . tag-list) + "[tag-name ...]" "Set the list of automatic tags" (trace `(auto-tags . ,tag-list)) (with-transaction db (lambda () @@ -94,33 +116,111 @@ (exec set-auto-tag-stmt 1 (car todo)) (loop (cdr todo))))))) -(define (print-tags) +(defcmd (list-tags) + "" "List available tag, automatic tags are marked with *" (query (for-each-row* (lambda (name auto) (write-line (conc " " name (if (= 0 auto) "" "*"))))) - print-tags-stmt)) + list-tags-stmt)) -(define (remove-auto-tag name . rest) +(defcmd (remove-auto-tag name . rest) + "[tag-name ...]" "Set tags as not automatic" (trace `(remove-auto-tag ,name)) (exec set-auto-tag-stmt 0 name) (unless (null? rest) (apply remove-auto-tag rest))) -(define (remove-tag name . rest) +(defcmd (remove-tag name . rest) + "tag-name [tag-name ...]" "Remove tags" (trace `(remove-tag ,name)) (exec remove-tag-stmt name) (unless (null? rest) (apply remove-tag rest))) -(define (rename-tag old-name new-name) +(defcmd (rename-tag old-name new-name) + "old-tag-name new-tag-name" "Rename a tag, preserving associations" (trace `(rename-tag ,old-name ,new-name)) (exec rename-tag-stmt old-name new-name)) +;; Entry Protection + +(define get-protected-stmt + (sql db "SELECT protected FROM entry WHERE id=?;")) +(define set-protected-stmt + (sql db "UPDATE entry SET protected=1,ptime=? WHERE id=?;")) +(define tmp-protected-stmt + (sql db "UPDATE entry SET protected=? WHERE id=?;")) +(define unset-protected-stmt + (sql db "UPDATE entry SET protected=0,ptime=NULL,mtime=? WHERE id=?;")) + +(define (is-protected? entry-id) + (not (= 0 (query fetch-value get-protected-stmt entry-id)))) + +(define-syntax unless-protected + (syntax-rules () + ((unless-protected entry-id . form) + (if (is-protected? entry-id) + (write-line (conc "Warning: entry " entry-id " is protected")) + (begin . form))))) + +(define (protect! time entry-id) + (trace `(protect! ,time ,entry-id)) + (exec tmp-protected-stmt 1 entry-id)) + +(define (protect* ptime entry-id) + (trace `(protect ,ptime ,entry-id)) + (unless-protected entry-id + (exec set-protected-stmt ptime entry-id))) + +(defcmd (protect . args) + "[timestamp] [entry-id]" "Protect entries from modification" + (cond ((null? args) + (protect* (current-seconds) cur-entry)) + ((null? (cdr args)) + (protect* (current-seconds) (car args))) + (else + (protect* (car args) (cadr args))))) + +(define (unprotect! time entry-id) + (trace `(unprotect! ,time ,entry-id)) + (exec tmp-protected-stmt 0 entry-id)) + +(define (unprotect* mtime entry-id) + (trace `(unprotect ,mtime ,entry-id)) + (exec unset-protected-stmt mtime entry-id)) + +(defcmd (unprotect . args) + "[timestamp] [entry-id]" "Unprotect entries from modification" + (cond ((null? args) + (unprotect* (current-seconds) cur-entry)) + ((null? (cdr args)) + (unprotect* (current-seconds) (car args))) + (else + (unprotect* (car args) (cadr args))))) + +(define (without-protection* time entry-id proc) + (if (is-protected? entry-id) + (begin + (unprotect! time entry-id) + (eval proc) + (protect! time entry-id)) + (eval proc))) + +(defcmd (without-protection! first . args) + "[[timestamp] entry-id] '(...)" "Perform updates bypassing protection" + (cond ((null? args) + (without-protection* (current-seconds) cur-entry first)) + ((and (null? (cdr args)) (integer? first)) + (without-protection* (current-seconds) first (car args))) + ((and (null? (cddr args)) (integer? first) (integer? (car args))) + (without-protection* first (car args) (cadr args))) + (else (assert #f "Invalid arguments " (cons first args))))) + ;; Entry Management (define add-entry-stmt - (sql db "INSERT INTO entry(url, notes) VALUES (?, ?);")) + (sql db "INSERT INTO entry(url, notes, ctime, mtime) VALUES (?, ?, ?, ?);")) (define auto-tag-stmt (sql db "INSERT INTO tagrel SELECT ?,id FROM tag WHERE auto = 1;")) (define select-entry-stmt @@ -128,39 +228,64 @@ (define select-untagged-stmt (sql db "SELECT id,url,notes FROM entry WHERE id NOT IN (SELECT url_id FROM tagrel);")) (define set-notes-stmt - (sql db "UPDATE entry SET notes=? WHERE id=?;")) + (sql db "UPDATE entry SET notes=?,mtime=? WHERE id=?;")) +(define touch-entry-stmt + (sql db "UPDATE entry SET mtime=? WHERE id=?;")) (define cur-entry (query fetch-value (sql/transient db "SELECT id FROM entry ORDER BY id DESC LIMIT 1;"))) -(define (add-entry url notes) - (trace `(add-entry ,url ,notes)) +(define (time-id-strings args) + (cond ((or (null? args) (string? (car args))) + (list (current-seconds) cur-entry args)) + ((not (integer? (car args))) + (assert #f "Unknown type parameter for " (car args))) + ((or (null? (cdr args)) (string? (cadr args))) + (list (current-seconds) (car args) (cdr args))) + ((integer? (cadr args)) + (list (car args) (cadr args) (cddr args))) + (else (assert #f "Unknown type parameter for " (cadr args))))) + +(define (add-entry* ctime url notes) + (trace `(add-entry ,ctime ,url ,notes)) (let ((new-id (with-transaction db (lambda () - (exec add-entry-stmt url notes) + (exec add-entry-stmt url notes ctime ctime) (let ((new-id (last-insert-rowid db))) (exec auto-tag-stmt new-id) new-id))))) (set! cur-entry new-id) (write-line (conc "Added " new-id)))) -(define (add-notes* entry-id lines) +(defcmd (add-entry first second . rest) + "[timestamp] URL note-line [note-line ...]" "Create a new entry" + (if (or (null? rest) (string? first)) + (add-entry* (current-seconds) + first + (apply string-append (map terminate-line (cons second rest)))) + (add-entry* first + second + (apply string-append (map terminate-line rest))))) + +(define (add-notes* mtime entry-id lines) (unless (null? lines) - (trace `(add-notes ,entry-id . ,lines)) + (trace `(add-notes ,mtime ,entry-id . ,lines)) (with-transaction db (lambda () (let ((prev-notes (caddr (query fetch-row select-entry-stmt entry-id)))) - (exec set-notes-stmt - (apply string-append prev-notes - (map (lambda (s) (string-append s "\n")) lines)) - entry-id)))))) - -(define (add-notes first . rest) - (cond ((integer? first) (add-notes* first rest)) - ((string? first) (add-notes* cur-entry (cons first rest))) - (else (assert #f "Unknown type parameter for " first)))) + (unless-protected entry-id + (exec set-notes-stmt + (apply string-append prev-notes + (map terminate-line lines)) + mtime + entry-id))))))) + +(defcmd (add-notes . args) + "[[timestamp] entry-id] note-line [note-line ...]" + "Append new lines of notes" + (apply add-notes* (time-id-strings args))) (define (print-entry-row row) (write-line (conc "#" (car row) " - " (cadr row))) @@ -171,7 +296,8 @@ select-entry-stmt entry-id)) -(define (print-entry . args) +(defcmd (print-entry . args) + "[entry-id]" "Display an entry" (if (null? args) (print-entry* cur-entry) (let loop ((todo args)) @@ -179,12 +305,32 @@ (print-entry* (car todo)) (loop (cdr todo)))))) -(define (print-untagged) +(defcmd (list-untagged) + "" "Display entries without any tag" (query (for-each-row print-entry-row) select-untagged-stmt)) -(define (set-entry entry-id) +(defcmd (set-entry entry-id) + "entry-id" "Set current entry" + (assert (integer? entry-id)) (set! cur-entry entry-id)) +(define (touch* mtime entry-id) + (trace `(touch ,mtime ,entry-id)) + (unless-protected entry-id + (exec touch-entry-stmt mtime entry-id))) + +(define (touch . args) + (cond ((null? args) + (touch* (current-seconds) entry-id)) + ((not (integer? (car args))) + (assert #f "Bad type for " (car args))) + ((null? (cdr args)) + (touch* (current-seconds) (car args))) + ((not (integer? (cadr args))) + (assert #f "Bad type for " (car args))) + (else + (touch* (car args) (cadr args))))) + ;; Entry Tagging (define exclude-tag-stmt @@ -201,7 +347,8 @@ (query (map-rows (lambda (x) (string-append " " (car x)))) select-tags-stmt entry-id))))) -(define (print-tags . args) +(defcmd (print-tags . args) + "[entry-id ...]" "Print tags associated with an entry" (if (null? args) (print-tags* cur-entry) (let loop ((todo args)) @@ -209,46 +356,78 @@ (print-tags* (car todo)) (loop (cdr todo)))))) -(define (exec-on-tags stmt entry-id tag-list) +(define (exec-on-tags stmt mtime entry-id tag-list) (with-transaction db (lambda () (let loop ((todo tag-list)) - (unless (null? todo) - (let ((tag-id (query fetch-value get-tag-id-stmt (car todo)))) - (if tag-id - (exec stmt entry-id tag-id) - (write-line (conc "Unknown tag " (car todo))))))))) + (if (null? todo) + (exec touch-entry-stmt mtime entry-id) + (let ((tag-id (query fetch-value get-tag-id-stmt (car todo)))) + (if tag-id + (unless-protected entry-id + (exec stmt entry-id tag-id)) + (write-line (conc "Unknown tag " (car todo))))))))) (print-tags entry-id)) -(define (tag* entry-id . tag-list) +(define (tag* mtime entry-id tag-list) (unless (null? tag-list) - (trace `(tag ,entry-id . ,tag-list)) - (exec-on-tags include-tag-stmt entry-id tag-list))) + (trace `(tag ,mtime ,entry-id . ,tag-list)) + (exec-on-tags include-tag-stmt mtime entry-id tag-list))) -(define (tag first . rest) - (cond ((integer? first) (apply tag* (cons first rest))) - ((string? first) (apply tag* (cons cur-entry (cons first rest)))) - (else (assert #f "Unknown type parameter for " first)))) +(defcmd (tag . args) + "[[timestamp] entry-id] tag-name [tag-name ...]" + "Associate tags to an entry" + (apply tag* (time-id-strings args))) -(define (untag* entry-id . tag-list) +(define (untag* mtime entry-id tag-list) (unless (null? tag-list) - (trace `(untag ,entry-id . ,tag-list)) - (exec-on-tags exclude-tag-stmt entry-id tag-list))) + (trace `(untag ,mtime ,entry-id . ,tag-list)) + (exec-on-tags exclude-tag-stmt mtime entry-id tag-list))) -(define (untag first . rest) - (cond ((integer? first) (apply untag* (cons first rest))) - ((string? first) (apply untag* (cons cur-entry (cons first rest)))) - (else (assert #f "Unknown type parameter for " first)))) +(defcmd (untag . args) + "[[timestamp] entry-id] tag-name [tag-name ...]" + "Disssociates tags from an entry" + (apply untag* (time-id-strings args))) ;;;;;;;;;;;;; ;; Auto Add -(define (auto-add line-list) - (trace `(auto-add ,line-list))) +(define (auto-add lines) + (trace `(auto-add ,lines)) + (let loop ((index 0) (urls '())) + (let* ((start0 (substring-index-ci "https://" lines index)) + (start (if start0 start0 + (substring-index-ci "http://" lines index))) + (end (if start + (min (string-length lines) + (substring-index " " lines start) + (substring-index "\n" lines start)) + #f))) + (cond (start + (loop end (cons (substring lines start end) urls))) + ((null? urls) + (write-line (conc "Warning: no URL found"))) + (else + (for-each (lambda (url) (add-entry url lines)) urls)))))) ;;;;;;;;;;;;;; ;; Main loop +(defcmd (help) + "" "Display this help" + (for-each + (lambda (row) + (write-line (conc + "(" + (car row) + (if (> (string-length (cadr row)) 0) " " "") + (cadr row) + ")")) + (write-line (conc " " (caddr row)))) + cmd-list)) + +(sort! cmd-list (lambda (r1 r2) (string<? (car r1) (car r2)))) + (set-signal-handler! signal/int (lambda _ (cleanup-after-signal!) @@ -279,13 +458,8 @@ (let data-loop ((acc (list (read-line)))) (if (char-ready?) (data-loop (cons (read-line) acc)) - (let ((lines (apply string-append - (map - (lambda (s) - (if (> (string-length s) 0) - (string-append s "\n") - s)) - (reverse acc))))) + (let ((lines (reverse-string-append + (map terminate-line acc)))) (when (> (string-length lines) 0) (auto-add lines)) (main-loop))))))))