diff options
Diffstat (limited to '')
-rw-r--r-- | module/vcomponent/data-stores/sqlite.scm | 180 |
1 files changed, 180 insertions, 0 deletions
diff --git a/module/vcomponent/data-stores/sqlite.scm b/module/vcomponent/data-stores/sqlite.scm new file mode 100644 index 00000000..f26cd688 --- /dev/null +++ b/module/vcomponent/data-stores/sqlite.scm @@ -0,0 +1,180 @@ +(define-module (vcomponent data-stores sqlite) + :use-module (sqlite3) + :use-module (oop goops) + :use-module (vcomponent data-stores common) + :use-module (srfi srfi-71) + :use-module ((srfi srfi-88) :select ()) + :use-module (vcomponent) + :use-module ((vcomponent formats ical) :prefix #{ical:}#) + :use-module ((hnh util) :select (aif)) + ) + +;; (define (sqlite-exec db str) +;; (display str) +;; ((@ (sqlite3) sqlite-exec) db str)) + +(define-class <sqlite-data-store> (<calendar-data-store>) + (database accessor: database) + (name init-keyword: name: getter: calendar-name) + ) + +(define (initialize-database db) + ;;; Setup Content type + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS content_type +( id INTEGER PRIMARY KEY AUTOINCREMENT +, name TEXT NOT NULL +)") + + (let ((stmt (sqlite-prepare db " +INSERT OR IGNORE INTO content_type +( name ) VALUES ( ? )"))) + (for-each (lambda (content-type) + (sqlite-reset stmt) + (sqlite-bind-arguments stmt ) + (sqlite-step stmt)) + '("ical" + "xcal" + "jcal"))) + + ;;; Setup calendar + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS calendar +( id INTEGER PRIMARY KEY AUTOINCREMENT +, name TEXT NOT NULL +)") + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS calendar_properties +( id INTEGER PRIMARY KEY AUTOINCREMENT +, calendar INTEGER NOT NULL +, key TEXT NOT NULL +, value TEXT NOT NULL +, FOREIGN KEY (calendar) REFERENCES calendar(id) +)") + + ;; INSERT INTO calendar_properties (id, key, value) + ;; VALUES ( (SELECT id FROM calendar WHERE name = 'Calendar') + ;; , 'color' + ;; , '#1E90FF') + + ;;; Setup event + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS event +( uid TEXT PRIMARY KEY +, content_type INTEGER NOT NULL +, content TEXT NOT NULL +, calendar INTEGER NOT NULL +, FOREIGN KEY (content_type) REFERENCES content_type(id) +, FOREIGN KEY (calendar) REFERENCES calendar(id) +)") + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS event_instances +( id INTEGER PRIMARY KEY AUTOINCREMENT +, event TEXT NOT NULL +, start DATETIME NOT NULL +, end DATETIME +, FOREIGN KEY (event) REFERENCES event(uid) +)") + + (sqlite-exec db " +CREATE TABLE IF NOT EXISTS event_instances_valid_range +( start DATETIME NOT NULL +, end DATETIME NOT NULL +)") + ) + +(define-method (initialize (this <sqlite-data-store>) args) + (next-method) + (if (calendar-name this) + (set! (database this) (sqlite-open (path this))) + (let ((path db-name + (aif (string-rindex (path this) #\#) + (values (substring (path this) 0 it) + (substring (path this) (1+ it))) + (scm-error 'misc-error "(initialize <sqlite-data-store>)" + "Target calendar name not specified" + '() #f)))) + (set! (database this) (sqlite-open path)) + (slot-set! this 'name db-name))) + + (initialize-database (database this))) + + +(define-method (get-calendar (this <sqlite-data-store>)) + (let ((db (database this)) + (calendar (make-vcomponent 'VCALENDAR))) + (let ((stmt (sqlite-prepare db " +SELECT key, value FROM calendar_properties cp +LEFT JOIN calendar c ON cp.calendar = c.id +WHERE c.name = ? +"))) + (sqlite-bind-arguments stmt (calendar-name this)) + (sqlite-fold (lambda (row calendar) + (let ((key (vector-ref row 0)) + (value (vector-ref row 1))) + (set-property! calendar + (string->symbol key) + value)) + calendar) + calendar + stmt)) + + (let ((stmt (sqlite-prepare db " +SELECT content_type.name, content +FROM event +LEFT JOIN calendar ON event.calendar = calendar.id +LEFT JOIN content_type ON event.content_type = content_type.id +WHERE calendar.name = ? +"))) + (sqlite-bind-arguments stmt (calendar-name this)) + (sqlite-fold (lambda (row calendar) + (case (string->symbol (vector-ref row 0)) + ((ical) + (add-child! calendar + (call-with-input-string (vector-ref row 1) + ics:deserialize)) + calendar) + (else + (scm-error 'misc-error "(get-calendar <sqlite-data-store>)" + "Only iCal data supported, got ~a" + (list (vector-ref row 0)) #f) + )) + ) + calendar + stmt)) + + calendar)) + + +#; +(define-method (get-by-uid (this <sqlite-data-store>) (uid <string>)) + (let ((stmt (sqlite-prepare db " +SELECT name, content +FROM event +LEFT JOIN content_type ON event.content_type = content_type.id +WHERE event.uid = ?"))) + (sqlite-bind-arguments stmt uid) + (cond ((sqlite-step stmt) + => (lambda (record) + (case (string->symbol (vector-ref content 0)) + ((ics) + ;; TODO dispatch to higher instance + ) + (else + (scm-error 'value-error "get-by-uid" + "Can only deserialize ics (uid=~s)" + (list uid) #f))) + + )) + (else + ;; TODO possibly throw no-such-value + #f + )) + + ) + ) |