diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-08-01 21:00:02 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-08-01 21:00:02 +0200 |
commit | 10d39d1fc6c6c9a9e4d17563c82fe98aa072da77 (patch) | |
tree | 3de6da2755e35b7a03f793880402a05cc3c3f14a /module/vcomponent.scm | |
parent | Add sqlite3.scm from Guile-sqlite. (diff) | |
download | calp-sql.tar.gz calp-sql.tar.xz |
Play around with sql.sql
Diffstat (limited to '')
-rw-r--r-- | module/vcomponent.scm | 249 |
1 files changed, 192 insertions, 57 deletions
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/-time<? (extract 'DTSTART))) - (setf 'repeating-events (sort*! repeating date/-time<? (extract 'DTSTART)))) + (for-each force-ids calendars) + (for-each (lambda (cal) (insert-vcomponent db cal #f)) + calendars) + (components->hash-map ht calendars) - (setf 'event-set - (interleave-streams - ev-time<? - (cons (list->stream (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-time<? (map generate-recurrence-set repeating-events))) + + (let ((target (date+ (current-date) (date year: 1)))) + (let ((stmt (sqlite-prepare + db "UPDATE stuff SET value = :value WHERE key = 'max-instance'"))) + (sqlite-bind-arguments stmt value: (date->string 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-time<? + (cons (list->stream 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-time<?))) - (let ((regular (getf 'fixed-events))) - (setf 'fixed-events (insert-ordered event regular ev-time<?)))) + (force-ids event) + (components->hash-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<? - (list (if (repeating? event) - (generate-recurrence-set event) - (stream event)) - event-set)))) - - (hash-set! (getf 'uid-map) (prop event 'UID) - event) + (set! (car event-set) + (interleave-streams + ev-time<? + (list (if (repeating? event) + (generate-recurrence-set event) + (stream event)) + (car event-set))))) (prop event 'UID)) (define-public (remove-event event) - (let ((events (delete event (getf 'events)))) - (setf 'events events)) - - (if (repeating? event) - (let ((repeating (delete event (getf 'repeating-events)))) - (setf 'repeating-events repeating)) - (let ((regular (delete event (getf 'fixed-events)))) - (setf 'fixed-events regular))) - - (let ((event-set - (stream-remove - (lambda (ev) - (equal? (prop ev 'UID) - (prop event 'UID))) - (getf 'event-set)))) - (setf 'event-set event-set)) - - (hash-set! (getf 'uid-map) (prop event 'UID) + + (let ((event-set (getf 'event-set))) + (set! (car event-set) + (stream-remove + (lambda (ev) + (equal? (prop ev 'UID) + (prop event 'UID))) + (car event-set)))) + + (hash-set! (getf 'uid-map) (prop event '-X-HNH-UID) #f)) |