7 files changed, 267 insertions, 0 deletions
diff --git a/module/vcomponent/data-stores/common.scm b/module/vcomponent/data-stores/common.scm
new file mode 100644
index 00000000..d6775141
--- /dev/null
+++ b/module/vcomponent/data-stores/common.scm
@@ -0,0 +1,26 @@
+(define-module (vcomponent data-stores common)
+  :use-module ((srfi srfi-88) :select ())
+  :use-module (oop goops)
+  :export (<calendar-data-store>
+           path
+           get-all
+           get-by-uid))
+
+
+(define-class <calendar-data-store> ()
+  (path init-keyword: path:
+        getter: path)
+  )
+
+
+(define-method (get-all (this <calendar-data-store>))
+  (scm-error 'not-implemented "get-all"
+             "Get-all is not implemented for ~s"
+             (list (class-of this))
+             #f))
+
+(define-method (get-by-uid (this <calendar-data-store>) (uid <string>))
+  (scm-error 'not-implemented "get-by-uid"
+             "Get-by-uid is not implemented for ~s"
+             (list (class-of this))
+             #f))
diff --git a/module/vcomponent/data-stores/file.scm b/module/vcomponent/data-stores/file.scm
new file mode 100644
index 00000000..0f09d81c
--- /dev/null
+++ b/module/vcomponent/data-stores/file.scm
@@ -0,0 +1,4 @@
+(define-module (vcomponent data-stores file)
+  :use-module (oop goops)
+  :use-module (vcomponent data-stores common)
+  )
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
+           ))
+
+    )
+  )
diff --git a/module/vcomponent/data-stores/vdir.scm b/module/vcomponent/data-stores/vdir.scm
new file mode 100644
index 00000000..fca59092
--- /dev/null
+++ b/module/vcomponent/data-stores/vdir.scm
@@ -0,0 +1,17 @@
+(define-module (vcomponent data-stores vdir)
+  :use-module (oop goops)
+  :use-module (vcomponent data-stores common)
+  :use-module ((srfi srfi-88) :select ())
+  :export ())
+
+(define-class <vdir-data-store> (<calendar-data-store>)
+  )
+
+(define-method (get-all (this <vdir-data-store>))
+  '())
+
+(define-method (get-by-uid (this <vdir-data-store>) (uid <string>))
+  #f
+  )
+
+;; (define (get-in-date-interval ))
diff --git a/module/vcomponent/formats/ical.scm b/module/vcomponent/formats/ical.scm
new file mode 100644
index 00000000..294642de
--- /dev/null
+++ b/module/vcomponent/formats/ical.scm
@@ -0,0 +1,18 @@
+(define-module (vcomponent formats ical)
+  :use-module ((vcomponent formats ical output)
+               :select (component->ical-string))
+  :use-module ((vcomponent formats ical parse)
+               :select (parse-calendar))
+  :export (serialize
+           deserialize
+           )
+   )
+
+
+(define (serialize component port)
+  (display (component->ical-string component)
+           port))
+
+(define (deserialize port)
+  (parse-calendar port)
+  )
diff --git a/module/vcomponent/formats/xcal.scm b/module/vcomponent/formats/xcal.scm
new file mode 100644
index 00000000..2732a5a7
--- /dev/null
+++ b/module/vcomponent/formats/xcal.scm
@@ -0,0 +1,20 @@
+(define-module (vcomponent formats xcal)
+  :use-module (sxml simple)
+  :use-module ((vcomponent formats xcal output)
+               :select (vcomponent->sxcal ns-wrap))
+  :use-module ((vcomponent formats xcal parse)
+               :select (sxcal->vcomponent))
+  :use-module ((hnh util) :select (->))
+  :export (serialize deserialize))
+
+
+(define (serialize component port)
+  (-> (vcomponent->sxcal component)
+      ns-wrap
+      (sxml->xml port)
+      ))
+
+
+(define (deserialize port)
+  (-> (xml->sxml port)
+      sxcal->vcomponent))
diff --git a/module/vcomponent/util/parse-cal-path.scm b/module/vcomponent/util/parse-cal-path.scm
index 24eee04e..fe3a6b7d 100644
--- a/module/vcomponent/util/parse-cal-path.scm
+++ b/module/vcomponent/util/parse-cal-path.scm
@@ -1,3 +1,5 @@
+;;; TODO remove this module, it should be part of the vdir interface
+
 (define-module (vcomponent util parse-cal-path)
   :use-module (hnh util)
   :use-module ((calp util time) :select (report-time!))