Play around with sql.sql

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/-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))