From 10d39d1fc6c6c9a9e4d17563c82fe98aa072da77 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 1 Aug 2020 21:00:02 +0200 Subject: Play around with sql. --- module/entry-points/server.scm | 4 +- module/output/html.scm | 4 +- module/output/terminal.scm | 2 +- module/vcomponent.scm | 249 +++++++++++++++++++++++++++++++---------- 4 files changed, 197 insertions(+), 62 deletions(-) diff --git a/module/entry-points/server.scm b/module/entry-points/server.scm index 5c3108cc..330ca3dd 100644 --- a/module/entry-points/server.scm +++ b/module/entry-points/server.scm @@ -78,7 +78,7 @@ (with-output-to-string (lambda () (html-generate calendars: (getf 'calendars) - events: (getf 'event-set) + events: (car (getf 'event-set)) start-date: start-date end-date: (date+ start-date (date day: 6)) next-start: (lambda (d) (date+ d (date day: 7))) @@ -94,7 +94,7 @@ (with-output-to-string (lambda () (html-generate calendars: (getf 'calendars) - events: (getf 'event-set) + events: (car (getf 'event-set)) start-date: start-date end-date: (date- (month+ start-date) (date day: 1)) diff --git a/module/output/html.scm b/module/output/html.scm index 8877de95..29f2140a 100644 --- a/module/output/html.scm +++ b/module/output/html.scm @@ -820,7 +820,7 @@ (define-method (html-chunked-main count start-date chunk-length) (define calendars (getf 'calendars)) - (define events (getf 'event-set)) + (define events (car (getf 'event-set))) ((@ (util time) report-time!) "html start") @@ -855,7 +855,7 @@ (define-method (html-table-main count start-date) (define calendars (getf 'calendars)) - (define events (getf 'event-set)) + (define events (car (getf 'event-set))) (create-files) diff --git a/module/output/terminal.scm b/module/output/terminal.scm index f4f46272..839b9275 100644 --- a/module/output/terminal.scm +++ b/module/output/terminal.scm @@ -337,7 +337,7 @@ (else (next-method)))) (app/define-method (main-loop date) - (define state (list (day-view (app/getf 'event-set) date))) + (define state (list (day-view (car (app/getf 'event-set)) date))) (while #t (output (car state)) diff --git a/module/vcomponent.scm b/module/vcomponent.scm index 2e13f1c8..571909ef 100644 --- a/module/vcomponent.scm +++ b/module/vcomponent.scm @@ -15,6 +15,112 @@ (re-export-modules (vcomponent base)) +(use-modules (sqlite3)) + +(define db (sqlite-open ":memory:")) + +;; (define db (sqlite-open "/home/hugo/cal.db")) + +(sqlite-exec db "DROP TABLE IF EXISTS vcomponents") + +(sqlite-exec db + " +CREATE TABLE vcomponents ( + id INTEGER PRIMARY KEY NOT NULL, + type TEXT NOT NULL, + repeating INTEGER DEFAULT 0, + uid TEXT, + dtstart TEXT, + dtend TEXT, + parent INTEGER REFERENCES vcomponents(id) +) +") + +(sqlite-exec db "DROP TABLE IF EXISTS instances") + +(sqlite-exec + db + " +CREATE TABLE instances ( + id INTEGER PRIMARY KEY NOT NULL, + dtstart TEXT NOT NULL, + event_id INTEGER REFERENCES vcomponents(id) +) +") + +(sqlite-exec db "DROP TABLE IF EXISTS stuff") + +(sqlite-exec + db + " +CREATE TABLE stuff ( + id INTEGER PRIMARY KEY NOT NULL, + key TEXT NOT NULL, + value +) +") + +(sqlite-exec db "INSERT INTO stuff (key) VALUES ('max-instance')") + +(define (get-events db ht clause . args) + (apply sqlite-query db (string-append + "SELECT uid FROM vcomponents WHERE " + clause) + (lambda (v) (hash-ref ht (vector-ref v 0))) + args + )) + +;; (sqlite-exec db "BEGIN TRANSACTION") +;; (sqlite-exec db "COMMIT TRANSACTION") + +(sqlite-exec db "PRAGMA synchronous=off") + +(define* (sqlite-query db str optional: (map identity) + key: DUMMY-KEY-DONT-USE #:allow-other-keys + rest: keys) + (let* ((stmt (sqlite-prepare db str))) + (apply sqlite-bind-arguments stmt keys) + (let ((return (sqlite-map map stmt))) + (sqlite-finalize stmt) + return))) + +#; +(define uids + (sqlite-query db "select uid from vcomponents +where parent = 1 and +type = 'VEVENT'" + (lambda (v) (vector-ref v 0)))) + +(define* (insert-vcomponent db component optional: parent) + (define stmt + (sqlite-prepare db + "INSERT INTO vcomponents (type, uid, dtstart, dtend, parent, repeating) +VALUES (:type, :uid, :dtstart, :dtend, :parent, :repeating)")) + (sqlite-bind-arguments + stmt + type: (symbol->string (type component)) + uid: (prop component 'UID) + dtstart: (aif (prop component 'DTSTART) + (datetime->string (as-datetime it) + "~Y-~m-~dT~H:~M:~S") + #f) + dtend: (aif (prop component 'DTEND) + (datetime->string (as-datetime it) + "~Y-~m-~dT~H:~M:~S") + #f) + parent: parent + repeating: (if (repeating? component) 1 0)) + (sqlite-step stmt) + (sqlite-finalize stmt) + + (unless (null? (children component)) + (let ((id + (car + (sqlite-query db "select last_insert_rowid()" + (lambda (v) (vector-ref v 0)))))) + (map (lambda (c) (insert-vcomponent db c id)) + (children component))))) + (define-config calendar-files '() "Which files to parse. Takes a list of paths or a single string which will be globbed." pre: (lambda (v) @@ -26,35 +132,80 @@ (map parse-cal-path calendar-files)) +(define (force-ids component) + (aif (prop component 'UID) + (set! (prop component '-X-HNH-UID) it) + (set! (prop component '-X-HNH-UID) (uuidgen))) + (for-each force-ids (children component))) + +(define (components->hash-map ht components) + (for-each (lambda (comp) + (hash-set! ht (prop comp '-X-HNH-UID) comp) + (components->hash-map ht (children comp))) + components)) + (define-method (init-app calendar-files) - (setf 'calendars (load-calendars calendar-files)) + (define calendars (load-calendars calendar-files)) + (define ht (make-hash-table 512) ) - (setf 'events - (concatenate - ;; TODO does this drop events? - (map (lambda (cal) (remove - (extract 'X-HNH-REMOVED) - (filter (lambda (o) (eq? 'VEVENT (type o))) - (children cal)))) - (getf 'calendars)))) + (setf 'calendars calendars) + (setf 'uid-map ht) - (let* ((repeating regular (partition repeating? (getf 'events)))) - (setf 'fixed-events (sort*! regular date/-timehash-map ht calendars) - (setf 'event-set - (interleave-streams - ev-timestream (getf 'fixed-events)) - (map generate-recurrence-set (getf 'repeating-events))))) + (sqlite-exec db "INSERT INTO instances (dtstart, event_id) +SELECT dtstart, id FROM vcomponents WHERE type = 'VEVENT' AND repeating = 0") + + (let ((fixed-events + (get-events db ht "type = 'VEVENT' AND repeating = 0")) + + (repeating-events + (get-events db ht "type = 'VEVENT' AND repeating = 1"))) + (define recurring-stream (interleave-streams + ev-timestring target "~Y-~m-~d")) + (sqlite-step stmt) + (sqlite-finalize stmt)) + (stream-for-each + (lambda (ev) + (define id (car (sqlite-query db "SELECT id FROM vcomponents WHERE uid = :uid" + (lambda (r) (vector-ref r 0)) + uid: (prop ev 'UID)))) + (define stmt (sqlite-prepare + db "INSERT INTO instances (dtstart, event_id) VALUES (:dtstart, :id)" + cache?: #t)) + (sqlite-bind-arguments + stmt id: id + dtstart: (datetime->string (as-datetime (prop ev 'DTSTART)) "~Y-~m-~dT~H:~M:~S")) + (sqlite-step stmt) + ) + (stream-take-while (lambda (e) (date< (as-date (prop e 'DTSTART)) + target)) + recurring-stream))) + + (setf 'event-set + (list + (interleave-streams + ev-timestream fixed-events) + (map generate-recurrence-set repeating-events))))))) - (setf 'uid-map - (let ((ht (make-hash-table))) - (for-each (lambda (event) (hash-set! ht (prop event 'UID) event)) (getf 'events)) - ht))) (define-method (fixed-events-in-range start end) + (get-events db (getf 'uid-map) + "type = 'VEVENT' AND start BETWEEN :start AND :end" + start: (date->string (as-date start) "~Y-~m-~d") + end: (date->string (as-date end) "~Y-~m-~d") + ) + #; (filter-sorted (lambda (ev) ((in-date-range? start end) (as-date (prop ev 'DTSTART)))) (getf 'fixed-events))) @@ -80,49 +231,33 @@ (unless (prop event 'UID) (set! (prop event 'UID) (uuidgen))) - (let ((events (getf 'events))) - (setf 'events (cons event events))) - - (if (repeating? event) - (let ((repeating (getf 'repeating-events))) - (setf 'repeating-events (insert-ordered event repeating ev-timehash-map (getf 'uid-map) event) + (insert-vcomponent db event (prop calendar '-X-HNH-UID)) (let ((event-set (getf 'event-set))) - (setf 'event-set - (interleave-streams - ev-time